diff --git a/Makefile b/Makefile index ac1c11d..f94092f 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,7 @@ # Build the cpdf command line tools and top level MODS = cpdfstrftime cpdf cpdfcommand -SOURCES = $(foreach x,$(MODS),$(x).ml $(x).mli) cpdfcommandrun.ml +SOURCES = cst2constr.h cst2constr.c unixsupport.h unixsupport.c gmtime.c gettimeofday.c cpdfunix.ml cpdfunix.mli $(foreach x,$(MODS),$(x).ml $(x).mli) cpdfcommandrun.ml RESULT = cpdf ANNOTATE = true diff --git a/OCamlMakefile b/OCamlMakefile index 43dc3e2..a3078e9 100644 --- a/OCamlMakefile +++ b/OCamlMakefile @@ -683,7 +683,7 @@ ifndef REAL_OCAMLC ALL_LDFLAGS := $(THREAD_FLAG) $(ALL_LDFLAGS) ifndef CREATE_LIB ifndef REAL_OCAMLFIND - ALL_LDFLAGS := unix.cma threads.cma $(ALL_LDFLAGS) + ALL_LDFLAGS := $(ALL_LDFLAGS) endif endif endif @@ -729,7 +729,7 @@ else ALL_LDFLAGS := $(THREAD_FLAG) $(ALL_LDFLAGS) ifndef CREATE_LIB ifndef REAL_OCAMLFIND - ALL_LDFLAGS := unix.cmxa threads.cmxa $(ALL_LDFLAGS) + ALL_LDFLAGS := $(ALL_LDFLAGS) endif endif endif diff --git a/cpdfstrftime.ml b/cpdfstrftime.ml index 03cd8fa..81424a7 100644 --- a/cpdfstrftime.ml +++ b/cpdfstrftime.ml @@ -1,77 +1,77 @@ (* C-Style strftime *) open Pdfutil -let strf_A t = - match t.Unix.tm_wday with +let strf_A t = "" + (*match t.Unix.tm_wday with | 0 -> "Sunday" | 1 -> "Monday" | 2 -> "Tuesday" | 3 -> "Wednesday" | 4 -> "Thursday" | 5 -> "Friday" | 6 -> "Saturday" - | _ -> "strf_AFail" + | _ -> "strf_AFail" *) let strf_a t = String.sub (strf_A t) 0 3 -let strf_B t = - match t.Unix.tm_mon with +let strf_B t = "" + (*match t.Unix.tm_mon with | 0 -> "January" | 1 -> "February" | 2 -> "March" | 3 -> "April" | 4 -> "May" | 5 -> "June" | 6 -> "July" | 7 -> "August" | 8 -> "September" | 9 -> "October" | 10 -> "November" - | 11 -> "December" | _ -> "strf_Bfail" + | 11 -> "December" | _ -> "strf_Bfail"*) let strf_b t = String.sub (strf_B t) 0 3 -let strf_d t = - let s = string_of_int t.Unix.tm_mday in - if String.length s = 1 then "0" ^ s else s +let strf_d t = "" + (*let s = string_of_int t.Unix.tm_mday in + if String.length s = 1 then "0" ^ s else s *) -let strf_e t = - let s = string_of_int t.Unix.tm_mday in - if String.length s = 1 then " " ^ s else s +let strf_e t = "" + (*let s = string_of_int t.Unix.tm_mday in + if String.length s = 1 then " " ^ s else s*) -let strf_H t = - let s = string_of_int t.Unix.tm_hour in - if String.length s = 1 then "0" ^ s else s +let strf_H t = "" + (*let s = string_of_int t.Unix.tm_hour in + if String.length s = 1 then "0" ^ s else s*) -let strf_I t = - let s = string_of_int (t.Unix.tm_hour mod 12) in - if String.length s = 1 then "0" ^ s else s +let strf_I t = "" + (*let s = string_of_int (t.Unix.tm_hour mod 12) in + if String.length s = 1 then "0" ^ s else s *) -let strf_j t = - let s = string_of_int t.Unix.tm_yday in +let strf_j t = "" + (*let s = string_of_int t.Unix.tm_yday in match String.length s with | 1 -> "00" ^ s | 2 -> "0" ^ s - | _ -> s + | _ -> s *) -let strf_m t = - let s = string_of_int (t.Unix.tm_mon + 1) in - if String.length s = 1 then "0" ^ s else s +let strf_m t = "" + (*let s = string_of_int (t.Unix.tm_mon + 1) in + if String.length s = 1 then "0" ^ s else s *) -let strf_M t = - let s = string_of_int t.Unix.tm_min in - if String.length s = 1 then "0" ^ s else s +let strf_M t = "" + (*let s = string_of_int t.Unix.tm_min in + if String.length s = 1 then "0" ^ s else s*) -let strf_p t = - if t.Unix.tm_hour >= 12 then "p.m" else "a.m" +let strf_p t = "" + (*if t.Unix.tm_hour >= 12 then "p.m" else "a.m"*) -let strf_S t = - let s = string_of_int t.Unix.tm_sec in - if String.length s = 1 then "0" ^ s else s +let strf_S t = "" + (*let s = string_of_int t.Unix.tm_sec in + if String.length s = 1 then "0" ^ s else s*) let strf_T t = strf_H t ^ ":" ^ strf_M t ^ ":" ^ strf_S t -let strf_u t = - match t.Unix.tm_wday with +let strf_u t = "" + (*match t.Unix.tm_wday with | 0 -> "7" - | n -> string_of_int (n + 1) + | n -> string_of_int (n + 1)*) -let strf_w t = - string_of_int t.Unix.tm_wday +let strf_w t = "" + (*string_of_int t.Unix.tm_wday *) -let strf_Y t = - string_of_int (t.Unix.tm_year + 1900) +let strf_Y t = "" + (*string_of_int (t.Unix.tm_year + 1900) *) let strf_percent _ = "%" @@ -82,12 +82,12 @@ let strftime_pairs = "%p", strf_p; "%S", strf_S; "%T", strf_T; "%u", strf_u; "%w", strf_w; "%Y", strf_Y; "%%", strf_percent] -let strftime text = - let time = Unix.localtime (Unix.gettimeofday ()) in +let strftime text = "" + (*let time = Unix.localtime (Unix.gettimeofday ()) in let text = ref text in iter (fun (search, replace_fun) -> text := string_replace_all search (replace_fun time) !text) strftime_pairs; - !text + !text*) diff --git a/cpdfunix.ml b/cpdfunix.ml new file mode 100644 index 0000000..8bd935f --- /dev/null +++ b/cpdfunix.ml @@ -0,0 +1,1074 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../../LICENSE. *) +(* *) +(***********************************************************************) + +type error = + E2BIG + | EACCES + | EAGAIN + | EBADF + | EBUSY + | ECHILD + | EDEADLK + | EDOM + | EEXIST + | EFAULT + | EFBIG + | EINTR + | EINVAL + | EIO + | EISDIR + | EMFILE + | EMLINK + | ENAMETOOLONG + | ENFILE + | ENODEV + | ENOENT + | ENOEXEC + | ENOLCK + | ENOMEM + | ENOSPC + | ENOSYS + | ENOTDIR + | ENOTEMPTY + | ENOTTY + | ENXIO + | EPERM + | EPIPE + | ERANGE + | EROFS + | ESPIPE + | ESRCH + | EXDEV + | EWOULDBLOCK + | EINPROGRESS + | EALREADY + | ENOTSOCK + | EDESTADDRREQ + | EMSGSIZE + | EPROTOTYPE + | ENOPROTOOPT + | EPROTONOSUPPORT + | ESOCKTNOSUPPORT + | EOPNOTSUPP + | EPFNOSUPPORT + | EAFNOSUPPORT + | EADDRINUSE + | EADDRNOTAVAIL + | ENETDOWN + | ENETUNREACH + | ENETRESET + | ECONNABORTED + | ECONNRESET + | ENOBUFS + | EISCONN + | ENOTCONN + | ESHUTDOWN + | ETOOMANYREFS + | ETIMEDOUT + | ECONNREFUSED + | EHOSTDOWN + | EHOSTUNREACH + | ELOOP + | EOVERFLOW + | EUNKNOWNERR of int + +exception Unix_error of error * string * string + +let _ = Callback.register_exception "Unix.Unix_error" + (Unix_error(E2BIG, "", "")) + +external error_message : error -> string = "unix_error_message" + +let () = + Printexc.register_printer + (function + | Unix_error (e, s, s') -> + let msg = match e with + | E2BIG -> "E2BIG" + | EACCES -> "EACCES" + | EAGAIN -> "EAGAIN" + | EBADF -> "EBADF" + | EBUSY -> "EBUSY" + | ECHILD -> "ECHILD" + | EDEADLK -> "EDEADLK" + | EDOM -> "EDOM" + | EEXIST -> "EEXIST" + | EFAULT -> "EFAULT" + | EFBIG -> "EFBIG" + | EINTR -> "EINTR" + | EINVAL -> "EINVAL" + | EIO -> "EIO" + | EISDIR -> "EISDIR" + | EMFILE -> "EMFILE" + | EMLINK -> "EMLINK" + | ENAMETOOLONG -> "ENAMETOOLONG" + | ENFILE -> "ENFILE" + | ENODEV -> "ENODEV" + | ENOENT -> "ENOENT" + | ENOEXEC -> "ENOEXEC" + | ENOLCK -> "ENOLCK" + | ENOMEM -> "ENOMEM" + | ENOSPC -> "ENOSPC" + | ENOSYS -> "ENOSYS" + | ENOTDIR -> "ENOTDIR" + | ENOTEMPTY -> "ENOTEMPTY" + | ENOTTY -> "ENOTTY" + | ENXIO -> "ENXIO" + | EPERM -> "EPERM" + | EPIPE -> "EPIPE" + | ERANGE -> "ERANGE" + | EROFS -> "EROFS" + | ESPIPE -> "ESPIPE" + | ESRCH -> "ESRCH" + | EXDEV -> "EXDEV" + | EWOULDBLOCK -> "EWOULDBLOCK" + | EINPROGRESS -> "EINPROGRESS" + | EALREADY -> "EALREADY" + | ENOTSOCK -> "ENOTSOCK" + | EDESTADDRREQ -> "EDESTADDRREQ" + | EMSGSIZE -> "EMSGSIZE" + | EPROTOTYPE -> "EPROTOTYPE" + | ENOPROTOOPT -> "ENOPROTOOPT" + | EPROTONOSUPPORT -> "EPROTONOSUPPORT" + | ESOCKTNOSUPPORT -> "ESOCKTNOSUPPORT" + | EOPNOTSUPP -> "EOPNOTSUPP" + | EPFNOSUPPORT -> "EPFNOSUPPORT" + | EAFNOSUPPORT -> "EAFNOSUPPORT" + | EADDRINUSE -> "EADDRINUSE" + | EADDRNOTAVAIL -> "EADDRNOTAVAIL" + | ENETDOWN -> "ENETDOWN" + | ENETUNREACH -> "ENETUNREACH" + | ENETRESET -> "ENETRESET" + | ECONNABORTED -> "ECONNABORTED" + | ECONNRESET -> "ECONNRESET" + | ENOBUFS -> "ENOBUFS" + | EISCONN -> "EISCONN" + | ENOTCONN -> "ENOTCONN" + | ESHUTDOWN -> "ESHUTDOWN" + | ETOOMANYREFS -> "ETOOMANYREFS" + | ETIMEDOUT -> "ETIMEDOUT" + | ECONNREFUSED -> "ECONNREFUSED" + | EHOSTDOWN -> "EHOSTDOWN" + | EHOSTUNREACH -> "EHOSTUNREACH" + | ELOOP -> "ELOOP" + | EOVERFLOW -> "EOVERFLOW" + | EUNKNOWNERR x -> Printf.sprintf "EUNKNOWNERR %d" x in + Some (Printf.sprintf "Unix.Unix_error(Unix.%s, %S, %S)" msg s s') + | _ -> None) + +let handle_unix_error f arg = + try + f arg + with Unix_error(err, fun_name, arg) -> + prerr_string Sys.argv.(0); + prerr_string ": \""; + prerr_string fun_name; + prerr_string "\" failed"; + if String.length arg > 0 then begin + prerr_string " on \""; + prerr_string arg; + prerr_string "\"" + end; + prerr_string ": "; + prerr_endline (error_message err); + exit 2 + +external environment : unit -> string array = "unix_environment" +external getenv: string -> string = "caml_sys_getenv" +external putenv: string -> string -> unit = "unix_putenv" + +type process_status = + WEXITED of int + | WSIGNALED of int + | WSTOPPED of int + +type wait_flag = + WNOHANG + | WUNTRACED + +external execv : string -> string array -> 'a = "unix_execv" +external execve : string -> string array -> string array -> 'a = "unix_execve" +external execvp : string -> string array -> 'a = "unix_execvp" +external execvpe : string -> string array -> string array -> 'a = "unix_execvpe" +external fork : unit -> int = "unix_fork" +external wait : unit -> int * process_status = "unix_wait" +external waitpid : wait_flag list -> int -> int * process_status + = "unix_waitpid" +external getpid : unit -> int = "unix_getpid" +external getppid : unit -> int = "unix_getppid" +external nice : int -> int = "unix_nice" + +type file_descr = int + +let stdin = 0 +let stdout = 1 +let stderr = 2 + +type open_flag = + O_RDONLY + | O_WRONLY + | O_RDWR + | O_NONBLOCK + | O_APPEND + | O_CREAT + | O_TRUNC + | O_EXCL + | O_NOCTTY + | O_DSYNC + | O_SYNC + | O_RSYNC + | O_SHARE_DELETE + | O_CLOEXEC + +type file_perm = int + + +external openfile : string -> open_flag list -> file_perm -> file_descr + = "unix_open" + +external close : file_descr -> unit = "unix_close" +external unsafe_read : file_descr -> string -> int -> int -> int = "unix_read" +external unsafe_write : file_descr -> string -> int -> int -> int = "unix_write" +external unsafe_single_write : file_descr -> string -> int -> int -> int + = "unix_single_write" + +let read fd buf ofs len = + if ofs < 0 || len < 0 || ofs > String.length buf - len + then invalid_arg "Unix.read" + else unsafe_read fd buf ofs len +let write fd buf ofs len = + if ofs < 0 || len < 0 || ofs > String.length buf - len + then invalid_arg "Unix.write" + else unsafe_write fd buf ofs len +(* write misbehaves because it attempts to write all data by making repeated + calls to the Unix write function (see comment in write.c and unix.mli). + partial_write fixes this by never calling write twice. *) +let single_write fd buf ofs len = + if ofs < 0 || len < 0 || ofs > String.length buf - len + then invalid_arg "Unix.single_write" + else unsafe_single_write fd buf ofs len + +external in_channel_of_descr : file_descr -> in_channel + = "caml_ml_open_descriptor_in" +external out_channel_of_descr : file_descr -> out_channel + = "caml_ml_open_descriptor_out" +external descr_of_in_channel : in_channel -> file_descr + = "caml_channel_descriptor" +external descr_of_out_channel : out_channel -> file_descr + = "caml_channel_descriptor" + +type seek_command = + SEEK_SET + | SEEK_CUR + | SEEK_END + +external lseek : file_descr -> int -> seek_command -> int = "unix_lseek" +external truncate : string -> int -> unit = "unix_truncate" +external ftruncate : file_descr -> int -> unit = "unix_ftruncate" + +type file_kind = + S_REG + | S_DIR + | S_CHR + | S_BLK + | S_LNK + | S_FIFO + | S_SOCK + +type stats = + { st_dev : int; + st_ino : int; + st_kind : file_kind; + st_perm : file_perm; + st_nlink : int; + st_uid : int; + st_gid : int; + st_rdev : int; + st_size : int; + st_atime : float; + st_mtime : float; + st_ctime : float } + +external stat : string -> stats = "unix_stat" +external lstat : string -> stats = "unix_lstat" +external fstat : file_descr -> stats = "unix_fstat" +external isatty : file_descr -> bool = "unix_isatty" +external unlink : string -> unit = "unix_unlink" +external rename : string -> string -> unit = "unix_rename" +external link : string -> string -> unit = "unix_link" + +module LargeFile = + struct + external lseek : file_descr -> int64 -> seek_command -> int64 + = "unix_lseek_64" + external truncate : string -> int64 -> unit = "unix_truncate_64" + external ftruncate : file_descr -> int64 -> unit = "unix_ftruncate_64" + type stats = + { st_dev : int; + st_ino : int; + st_kind : file_kind; + st_perm : file_perm; + st_nlink : int; + st_uid : int; + st_gid : int; + st_rdev : int; + st_size : int64; + st_atime : float; + st_mtime : float; + st_ctime : float; + } + external stat : string -> stats = "unix_stat_64" + external lstat : string -> stats = "unix_lstat_64" + external fstat : file_descr -> stats = "unix_fstat_64" + end + +type access_permission = + R_OK + | W_OK + | X_OK + | F_OK + +external chmod : string -> file_perm -> unit = "unix_chmod" +external fchmod : file_descr -> file_perm -> unit = "unix_fchmod" +external chown : string -> int -> int -> unit = "unix_chown" +external fchown : file_descr -> int -> int -> unit = "unix_fchown" +external umask : int -> int = "unix_umask" +external access : string -> access_permission list -> unit = "unix_access" + +external dup : file_descr -> file_descr = "unix_dup" +external dup2 : file_descr -> file_descr -> unit = "unix_dup2" +external set_nonblock : file_descr -> unit = "unix_set_nonblock" +external clear_nonblock : file_descr -> unit = "unix_clear_nonblock" +external set_close_on_exec : file_descr -> unit = "unix_set_close_on_exec" +external clear_close_on_exec : file_descr -> unit = "unix_clear_close_on_exec" + +(* FD_CLOEXEC should be supported on all Unix systems these days, + but just in case... *) +let try_set_close_on_exec fd = + try set_close_on_exec fd; true with Invalid_argument _ -> false + +external mkdir : string -> file_perm -> unit = "unix_mkdir" +external rmdir : string -> unit = "unix_rmdir" +external chdir : string -> unit = "unix_chdir" +external getcwd : unit -> string = "unix_getcwd" +external chroot : string -> unit = "unix_chroot" + +type dir_handle + +external opendir : string -> dir_handle = "unix_opendir" +external readdir : dir_handle -> string = "unix_readdir" +external rewinddir : dir_handle -> unit = "unix_rewinddir" +external closedir : dir_handle -> unit = "unix_closedir" + +external pipe : unit -> file_descr * file_descr = "unix_pipe" +external symlink : string -> string -> unit = "unix_symlink" +external readlink : string -> string = "unix_readlink" +external mkfifo : string -> file_perm -> unit = "unix_mkfifo" +external select : + file_descr list -> file_descr list -> file_descr list -> float -> + file_descr list * file_descr list * file_descr list = "unix_select" + +type lock_command = + F_ULOCK + | F_LOCK + | F_TLOCK + | F_TEST + | F_RLOCK + | F_TRLOCK + +external lockf : file_descr -> lock_command -> int -> unit = "unix_lockf" +external kill : int -> int -> unit = "unix_kill" +type sigprocmask_command = SIG_SETMASK | SIG_BLOCK | SIG_UNBLOCK +external sigprocmask: sigprocmask_command -> int list -> int list + = "unix_sigprocmask" +external sigpending: unit -> int list = "unix_sigpending" +external sigsuspend: int list -> unit = "unix_sigsuspend" + +let pause() = + let sigs = sigprocmask SIG_BLOCK [] in sigsuspend sigs + +type process_times = + { tms_utime : float; + tms_stime : float; + tms_cutime : float; + tms_cstime : float } + +type tm = + { tm_sec : int; + tm_min : int; + tm_hour : int; + tm_mday : int; + tm_mon : int; + tm_year : int; + tm_wday : int; + tm_yday : int; + tm_isdst : bool } + +external time : unit -> float = "unix_time" +external gettimeofday : unit -> float = "unix_gettimeofday" +external gmtime : float -> tm = "unix_gmtime" +external localtime : float -> tm = "unix_localtime" +external mktime : tm -> float * tm = "unix_mktime" +external alarm : int -> int = "unix_alarm" +external sleep : int -> unit = "unix_sleep" +external times : unit -> process_times = "unix_times" +external utimes : string -> float -> float -> unit = "unix_utimes" + +type interval_timer = + ITIMER_REAL + | ITIMER_VIRTUAL + | ITIMER_PROF + +type interval_timer_status = + { it_interval: float; (* Period *) + it_value: float } (* Current value of the timer *) + +external getitimer: interval_timer -> interval_timer_status = "unix_getitimer" +external setitimer: + interval_timer -> interval_timer_status -> interval_timer_status + = "unix_setitimer" + +external getuid : unit -> int = "unix_getuid" +external geteuid : unit -> int = "unix_geteuid" +external setuid : int -> unit = "unix_setuid" +external getgid : unit -> int = "unix_getgid" +external getegid : unit -> int = "unix_getegid" +external setgid : int -> unit = "unix_setgid" +external getgroups : unit -> int array = "unix_getgroups" +external setgroups : int array -> unit = "unix_setgroups" +external initgroups : string -> int -> unit = "unix_initgroups" + +type passwd_entry = + { pw_name : string; + pw_passwd : string; + pw_uid : int; + pw_gid : int; + pw_gecos : string; + pw_dir : string; + pw_shell : string } + +type group_entry = + { gr_name : string; + gr_passwd : string; + gr_gid : int; + gr_mem : string array } + + +external getlogin : unit -> string = "unix_getlogin" +external getpwnam : string -> passwd_entry = "unix_getpwnam" +external getgrnam : string -> group_entry = "unix_getgrnam" +external getpwuid : int -> passwd_entry = "unix_getpwuid" +external getgrgid : int -> group_entry = "unix_getgrgid" + +type inet_addr = string + +let is_inet6_addr s = String.length s = 16 + +external inet_addr_of_string : string -> inet_addr + = "unix_inet_addr_of_string" +external string_of_inet_addr : inet_addr -> string + = "unix_string_of_inet_addr" + +let inet_addr_any = inet_addr_of_string "0.0.0.0" +let inet_addr_loopback = inet_addr_of_string "127.0.0.1" +let inet6_addr_any = + try inet_addr_of_string "::" with Failure _ -> inet_addr_any +let inet6_addr_loopback = + try inet_addr_of_string "::1" with Failure _ -> inet_addr_loopback + +type socket_domain = + PF_UNIX + | PF_INET + | PF_INET6 + +type socket_type = + SOCK_STREAM + | SOCK_DGRAM + | SOCK_RAW + | SOCK_SEQPACKET + +type sockaddr = + ADDR_UNIX of string + | ADDR_INET of inet_addr * int + +let domain_of_sockaddr = function + ADDR_UNIX _ -> PF_UNIX + | ADDR_INET(a, _) -> if is_inet6_addr a then PF_INET6 else PF_INET + +type shutdown_command = + SHUTDOWN_RECEIVE + | SHUTDOWN_SEND + | SHUTDOWN_ALL + +type msg_flag = + MSG_OOB + | MSG_DONTROUTE + | MSG_PEEK + +external socket : socket_domain -> socket_type -> int -> file_descr + = "unix_socket" +external socketpair : + socket_domain -> socket_type -> int -> file_descr * file_descr + = "unix_socketpair" +external accept : file_descr -> file_descr * sockaddr = "unix_accept" +external bind : file_descr -> sockaddr -> unit = "unix_bind" +external connect : file_descr -> sockaddr -> unit = "unix_connect" +external listen : file_descr -> int -> unit = "unix_listen" +external shutdown : file_descr -> shutdown_command -> unit = "unix_shutdown" +external getsockname : file_descr -> sockaddr = "unix_getsockname" +external getpeername : file_descr -> sockaddr = "unix_getpeername" + +external unsafe_recv : + file_descr -> string -> int -> int -> msg_flag list -> int + = "unix_recv" +external unsafe_recvfrom : + file_descr -> string -> int -> int -> msg_flag list -> int * sockaddr + = "unix_recvfrom" +external unsafe_send : + file_descr -> string -> int -> int -> msg_flag list -> int + = "unix_send" +external unsafe_sendto : + file_descr -> string -> int -> int -> msg_flag list -> sockaddr -> int + = "unix_sendto" "unix_sendto_native" + +let recv fd buf ofs len flags = + if ofs < 0 || len < 0 || ofs > String.length buf - len + then invalid_arg "Unix.recv" + else unsafe_recv fd buf ofs len flags +let recvfrom fd buf ofs len flags = + if ofs < 0 || len < 0 || ofs > String.length buf - len + then invalid_arg "Unix.recvfrom" + else unsafe_recvfrom fd buf ofs len flags +let send fd buf ofs len flags = + if ofs < 0 || len < 0 || ofs > String.length buf - len + then invalid_arg "Unix.send" + else unsafe_send fd buf ofs len flags +let sendto fd buf ofs len flags addr = + if ofs < 0 || len < 0 || ofs > String.length buf - len + then invalid_arg "Unix.sendto" + else unsafe_sendto fd buf ofs len flags addr + +type socket_bool_option = + SO_DEBUG + | SO_BROADCAST + | SO_REUSEADDR + | SO_KEEPALIVE + | SO_DONTROUTE + | SO_OOBINLINE + | SO_ACCEPTCONN + | TCP_NODELAY + | IPV6_ONLY + +type socket_int_option = + SO_SNDBUF + | SO_RCVBUF + | SO_ERROR + | SO_TYPE + | SO_RCVLOWAT + | SO_SNDLOWAT + +type socket_optint_option = SO_LINGER + +type socket_float_option = + SO_RCVTIMEO + | SO_SNDTIMEO + +type socket_error_option = SO_ERROR + +module SO: sig + type ('opt, 'v) t + val bool: (socket_bool_option, bool) t + val int: (socket_int_option, int) t + val optint: (socket_optint_option, int option) t + val float: (socket_float_option, float) t + val error: (socket_error_option, error option) t + val get: ('opt, 'v) t -> file_descr -> 'opt -> 'v + val set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit +end = struct + type ('opt, 'v) t = int + let bool = 0 + let int = 1 + let optint = 2 + let float = 3 + let error = 4 + external get: ('opt, 'v) t -> file_descr -> 'opt -> 'v + = "unix_getsockopt" + external set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit + = "unix_setsockopt" +end + +let getsockopt fd opt = SO.get SO.bool fd opt +let setsockopt fd opt v = SO.set SO.bool fd opt v + +let getsockopt_int fd opt = SO.get SO.int fd opt +let setsockopt_int fd opt v = SO.set SO.int fd opt v + +let getsockopt_optint fd opt = SO.get SO.optint fd opt +let setsockopt_optint fd opt v = SO.set SO.optint fd opt v + +let getsockopt_float fd opt = SO.get SO.float fd opt +let setsockopt_float fd opt v = SO.set SO.float fd opt v + +let getsockopt_error fd = SO.get SO.error fd SO_ERROR + +type host_entry = + { h_name : string; + h_aliases : string array; + h_addrtype : socket_domain; + h_addr_list : inet_addr array } + +type protocol_entry = + { p_name : string; + p_aliases : string array; + p_proto : int } + +type service_entry = + { s_name : string; + s_aliases : string array; + s_port : int; + s_proto : string } + +external gethostname : unit -> string = "unix_gethostname" +external gethostbyname : string -> host_entry = "unix_gethostbyname" +external gethostbyaddr : inet_addr -> host_entry = "unix_gethostbyaddr" +external getprotobyname : string -> protocol_entry + = "unix_getprotobyname" +external getprotobynumber : int -> protocol_entry + = "unix_getprotobynumber" +external getservbyname : string -> string -> service_entry + = "unix_getservbyname" +external getservbyport : int -> string -> service_entry + = "unix_getservbyport" + +type addr_info = + { ai_family : socket_domain; + ai_socktype : socket_type; + ai_protocol : int; + ai_addr : sockaddr; + ai_canonname : string } + +type getaddrinfo_option = + AI_FAMILY of socket_domain + | AI_SOCKTYPE of socket_type + | AI_PROTOCOL of int + | AI_NUMERICHOST + | AI_CANONNAME + | AI_PASSIVE + +external getaddrinfo_system + : string -> string -> getaddrinfo_option list -> addr_info list + = "unix_getaddrinfo" + +let getaddrinfo_emulation node service opts = + (* Parse options *) + let opt_socktype = ref None + and opt_protocol = ref 0 + and opt_passive = ref false in + List.iter + (function AI_SOCKTYPE s -> opt_socktype := Some s + | AI_PROTOCOL p -> opt_protocol := p + | AI_PASSIVE -> opt_passive := true + | _ -> ()) + opts; + (* Determine socket types and port numbers *) + let get_port ty kind = + if service = "" then [ty, 0] else + try + [ty, int_of_string service] + with Failure _ -> + try + [ty, (getservbyname service kind).s_port] + with Not_found -> [] + in + let ports = + match !opt_socktype with + | None -> + get_port SOCK_STREAM "tcp" @ get_port SOCK_DGRAM "udp" + | Some SOCK_STREAM -> + get_port SOCK_STREAM "tcp" + | Some SOCK_DGRAM -> + get_port SOCK_DGRAM "udp" + | Some ty -> + if service = "" then [ty, 0] else [] in + (* Determine IP addresses *) + let addresses = + if node = "" then + if List.mem AI_PASSIVE opts + then [inet_addr_any, "0.0.0.0"] + else [inet_addr_loopback, "127.0.0.1"] + else + try + [inet_addr_of_string node, node] + with Failure _ -> + try + let he = gethostbyname node in + List.map + (fun a -> (a, he.h_name)) + (Array.to_list he.h_addr_list) + with Not_found -> + [] in + (* Cross-product of addresses and ports *) + List.flatten + (List.map + (fun (ty, port) -> + List.map + (fun (addr, name) -> + { ai_family = PF_INET; + ai_socktype = ty; + ai_protocol = !opt_protocol; + ai_addr = ADDR_INET(addr, port); + ai_canonname = name }) + addresses) + ports) + +let getaddrinfo node service opts = + try + List.rev(getaddrinfo_system node service opts) + with Invalid_argument _ -> + getaddrinfo_emulation node service opts + +type name_info = + { ni_hostname : string; + ni_service : string } + +type getnameinfo_option = + NI_NOFQDN + | NI_NUMERICHOST + | NI_NAMEREQD + | NI_NUMERICSERV + | NI_DGRAM + +external getnameinfo_system + : sockaddr -> getnameinfo_option list -> name_info + = "unix_getnameinfo" + +let getnameinfo_emulation addr opts = + match addr with + | ADDR_UNIX f -> + { ni_hostname = ""; ni_service = f } (* why not? *) + | ADDR_INET(a, p) -> + let hostname = + try + if List.mem NI_NUMERICHOST opts then raise Not_found; + (gethostbyaddr a).h_name + with Not_found -> + if List.mem NI_NAMEREQD opts then raise Not_found; + string_of_inet_addr a in + let service = + try + if List.mem NI_NUMERICSERV opts then raise Not_found; + let kind = if List.mem NI_DGRAM opts then "udp" else "tcp" in + (getservbyport p kind).s_name + with Not_found -> + string_of_int p in + { ni_hostname = hostname; ni_service = service } + +let getnameinfo addr opts = + try + getnameinfo_system addr opts + with Invalid_argument _ -> + getnameinfo_emulation addr opts + +type terminal_io = { + mutable c_ignbrk: bool; + mutable c_brkint: bool; + mutable c_ignpar: bool; + mutable c_parmrk: bool; + mutable c_inpck: bool; + mutable c_istrip: bool; + mutable c_inlcr: bool; + mutable c_igncr: bool; + mutable c_icrnl: bool; + mutable c_ixon: bool; + mutable c_ixoff: bool; + mutable c_opost: bool; + mutable c_obaud: int; + mutable c_ibaud: int; + mutable c_csize: int; + mutable c_cstopb: int; + mutable c_cread: bool; + mutable c_parenb: bool; + mutable c_parodd: bool; + mutable c_hupcl: bool; + mutable c_clocal: bool; + mutable c_isig: bool; + mutable c_icanon: bool; + mutable c_noflsh: bool; + mutable c_echo: bool; + mutable c_echoe: bool; + mutable c_echok: bool; + mutable c_echonl: bool; + mutable c_vintr: char; + mutable c_vquit: char; + mutable c_verase: char; + mutable c_vkill: char; + mutable c_veof: char; + mutable c_veol: char; + mutable c_vmin: int; + mutable c_vtime: int; + mutable c_vstart: char; + mutable c_vstop: char + } + +external tcgetattr: file_descr -> terminal_io = "unix_tcgetattr" + +type setattr_when = TCSANOW | TCSADRAIN | TCSAFLUSH + +external tcsetattr: file_descr -> setattr_when -> terminal_io -> unit + = "unix_tcsetattr" +external tcsendbreak: file_descr -> int -> unit = "unix_tcsendbreak" +external tcdrain: file_descr -> unit = "unix_tcdrain" + +type flush_queue = TCIFLUSH | TCOFLUSH | TCIOFLUSH + +external tcflush: file_descr -> flush_queue -> unit = "unix_tcflush" + +type flow_action = TCOOFF | TCOON | TCIOFF | TCION + +external tcflow: file_descr -> flow_action -> unit = "unix_tcflow" + +external setsid : unit -> int = "unix_setsid" + +(* High-level process management (system, popen) *) + +let rec waitpid_non_intr pid = + try waitpid [] pid + with Unix_error (EINTR, _, _) -> waitpid_non_intr pid + +let system cmd = + match fork() with + 0 -> begin try + execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |] + with _ -> + exit 127 + end + | id -> snd(waitpid_non_intr id) + +let rec safe_dup fd = + let new_fd = dup fd in + if new_fd >= 3 then + new_fd + else begin + let res = safe_dup fd in + close new_fd; + res + end + +let safe_close fd = + try close fd with Unix_error(_,_,_) -> () + +let perform_redirections new_stdin new_stdout new_stderr = + let newnewstdin = safe_dup new_stdin in + let newnewstdout = safe_dup new_stdout in + let newnewstderr = safe_dup new_stderr in + safe_close new_stdin; + safe_close new_stdout; + safe_close new_stderr; + dup2 newnewstdin stdin; close newnewstdin; + dup2 newnewstdout stdout; close newnewstdout; + dup2 newnewstderr stderr; close newnewstderr + +let create_process cmd args new_stdin new_stdout new_stderr = + match fork() with + 0 -> + begin try + perform_redirections new_stdin new_stdout new_stderr; + execvp cmd args + with _ -> + exit 127 + end + | id -> id + +let create_process_env cmd args env new_stdin new_stdout new_stderr = + match fork() with + 0 -> + begin try + perform_redirections new_stdin new_stdout new_stderr; + execvpe cmd args env + with _ -> + exit 127 + end + | id -> id + +type popen_process = + Process of in_channel * out_channel + | Process_in of in_channel + | Process_out of out_channel + | Process_full of in_channel * out_channel * in_channel + +let popen_processes = (Hashtbl.create 7 : (popen_process, int) Hashtbl.t) + +let open_proc cmd proc input output toclose = + let cloexec = List.for_all try_set_close_on_exec toclose in + match fork() with + 0 -> if input <> stdin then begin dup2 input stdin; close input end; + if output <> stdout then begin dup2 output stdout; close output end; + if not cloexec then List.iter close toclose; + begin try execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |] + with _ -> exit 127 + end + | id -> Hashtbl.add popen_processes proc id + +let open_process_in cmd = + let (in_read, in_write) = pipe() in + let inchan = in_channel_of_descr in_read in + begin + try + open_proc cmd (Process_in inchan) stdin in_write [in_read]; + with e -> + close_in inchan; + close in_write; + raise e + end; + close in_write; + inchan + +let open_process_out cmd = + let (out_read, out_write) = pipe() in + let outchan = out_channel_of_descr out_write in + begin + try + open_proc cmd (Process_out outchan) out_read stdout [out_write]; + with e -> + close_out outchan; + close out_read; + raise e + end; + close out_read; + outchan + +let open_process cmd = + let (in_read, in_write) = pipe() in + let fds_to_close = ref [in_read;in_write] in + try + let (out_read, out_write) = pipe() in + fds_to_close := [in_read;in_write;out_read;out_write]; + let inchan = in_channel_of_descr in_read in + let outchan = out_channel_of_descr out_write in + open_proc cmd (Process(inchan, outchan)) out_read in_write + [in_read; out_write]; + close out_read; + close in_write; + (inchan, outchan) + with e -> + List.iter close !fds_to_close; + raise e + +let open_proc_full cmd env proc input output error toclose = + let cloexec = List.for_all try_set_close_on_exec toclose in + match fork() with + 0 -> dup2 input stdin; close input; + dup2 output stdout; close output; + dup2 error stderr; close error; + if not cloexec then List.iter close toclose; + begin try execve "/bin/sh" [| "/bin/sh"; "-c"; cmd |] env + with _ -> exit 127 + end + | id -> Hashtbl.add popen_processes proc id + +let open_process_full cmd env = + let (in_read, in_write) = pipe() in + let fds_to_close = ref [in_read;in_write] in + try + let (out_read, out_write) = pipe() in + fds_to_close := out_read::out_write:: !fds_to_close; + let (err_read, err_write) = pipe() in + fds_to_close := err_read::err_write:: !fds_to_close; + let inchan = in_channel_of_descr in_read in + let outchan = out_channel_of_descr out_write in + let errchan = in_channel_of_descr err_read in + open_proc_full cmd env (Process_full(inchan, outchan, errchan)) + out_read in_write err_write [in_read; out_write; err_read]; + close out_read; + close in_write; + close err_write; + (inchan, outchan, errchan) + with e -> + List.iter close !fds_to_close; + raise e + +let find_proc_id fun_name proc = + try + let pid = Hashtbl.find popen_processes proc in + Hashtbl.remove popen_processes proc; + pid + with Not_found -> + raise(Unix_error(EBADF, fun_name, "")) + +let close_process_in inchan = + let pid = find_proc_id "close_process_in" (Process_in inchan) in + close_in inchan; + snd(waitpid_non_intr pid) + +let close_process_out outchan = + let pid = find_proc_id "close_process_out" (Process_out outchan) in + close_out outchan; + snd(waitpid_non_intr pid) + +let close_process (inchan, outchan) = + let pid = find_proc_id "close_process" (Process(inchan, outchan)) in + close_in inchan; + begin try close_out outchan with Sys_error _ -> () end; + snd(waitpid_non_intr pid) + +let close_process_full (inchan, outchan, errchan) = + let pid = + find_proc_id "close_process_full" + (Process_full(inchan, outchan, errchan)) in + close_in inchan; + begin try close_out outchan with Sys_error _ -> () end; + close_in errchan; + snd(waitpid_non_intr pid) + +(* High-level network functions *) + +let open_connection sockaddr = + let sock = + socket (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in + try + connect sock sockaddr; + ignore(try_set_close_on_exec sock); + (in_channel_of_descr sock, out_channel_of_descr sock) + with exn -> + close sock; raise exn + +let shutdown_connection inchan = + shutdown (descr_of_in_channel inchan) SHUTDOWN_SEND + +let rec accept_non_intr s = + try accept s + with Unix_error (EINTR, _, _) -> accept_non_intr s + +let establish_server server_fun sockaddr = + let sock = + socket (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in + setsockopt sock SO_REUSEADDR true; + bind sock sockaddr; + listen sock 5; + while true do + let (s, caller) = accept_non_intr sock in + (* The "double fork" trick, the process which calls server_fun will not + leave a zombie process *) + match fork() with + 0 -> if fork() <> 0 then exit 0; (* The son exits, the grandson works *) + close sock; + ignore(try_set_close_on_exec s); + let inchan = in_channel_of_descr s in + let outchan = out_channel_of_descr s in + server_fun inchan outchan; + (* Do not close inchan nor outchan, as the server_fun could + have done it already, and we are about to exit anyway + (PR#3794) *) + exit 0 + | id -> close s; ignore(waitpid_non_intr id) (* Reclaim the son *) + done diff --git a/cpdfunix.mli b/cpdfunix.mli new file mode 100644 index 0000000..a483e42 --- /dev/null +++ b/cpdfunix.mli @@ -0,0 +1,1340 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../../LICENSE. *) +(* *) +(***********************************************************************) + +(** Interface to the Unix system *) + + +(** {6 Error report} *) + + +type error = + E2BIG (** Argument list too long *) + | EACCES (** Permission denied *) + | EAGAIN (** Resource temporarily unavailable; try again *) + | EBADF (** Bad file descriptor *) + | EBUSY (** Resource unavailable *) + | ECHILD (** No child process *) + | EDEADLK (** Resource deadlock would occur *) + | EDOM (** Domain error for math functions, etc. *) + | EEXIST (** File exists *) + | EFAULT (** Bad address *) + | EFBIG (** File too large *) + | EINTR (** Function interrupted by signal *) + | EINVAL (** Invalid argument *) + | EIO (** Hardware I/O error *) + | EISDIR (** Is a directory *) + | EMFILE (** Too many open files by the process *) + | EMLINK (** Too many links *) + | ENAMETOOLONG (** Filename too long *) + | ENFILE (** Too many open files in the system *) + | ENODEV (** No such device *) + | ENOENT (** No such file or directory *) + | ENOEXEC (** Not an executable file *) + | ENOLCK (** No locks available *) + | ENOMEM (** Not enough memory *) + | ENOSPC (** No space left on device *) + | ENOSYS (** Function not supported *) + | ENOTDIR (** Not a directory *) + | ENOTEMPTY (** Directory not empty *) + | ENOTTY (** Inappropriate I/O control operation *) + | ENXIO (** No such device or address *) + | EPERM (** Operation not permitted *) + | EPIPE (** Broken pipe *) + | ERANGE (** Result too large *) + | EROFS (** Read-only file system *) + | ESPIPE (** Invalid seek e.g. on a pipe *) + | ESRCH (** No such process *) + | EXDEV (** Invalid link *) + | EWOULDBLOCK (** Operation would block *) + | EINPROGRESS (** Operation now in progress *) + | EALREADY (** Operation already in progress *) + | ENOTSOCK (** Socket operation on non-socket *) + | EDESTADDRREQ (** Destination address required *) + | EMSGSIZE (** Message too long *) + | EPROTOTYPE (** Protocol wrong type for socket *) + | ENOPROTOOPT (** Protocol not available *) + | EPROTONOSUPPORT (** Protocol not supported *) + | ESOCKTNOSUPPORT (** Socket type not supported *) + | EOPNOTSUPP (** Operation not supported on socket *) + | EPFNOSUPPORT (** Protocol family not supported *) + | EAFNOSUPPORT (** Address family not supported by protocol family *) + | EADDRINUSE (** Address already in use *) + | EADDRNOTAVAIL (** Can't assign requested address *) + | ENETDOWN (** Network is down *) + | ENETUNREACH (** Network is unreachable *) + | ENETRESET (** Network dropped connection on reset *) + | ECONNABORTED (** Software caused connection abort *) + | ECONNRESET (** Connection reset by peer *) + | ENOBUFS (** No buffer space available *) + | EISCONN (** Socket is already connected *) + | ENOTCONN (** Socket is not connected *) + | ESHUTDOWN (** Can't send after socket shutdown *) + | ETOOMANYREFS (** Too many references: can't splice *) + | ETIMEDOUT (** Connection timed out *) + | ECONNREFUSED (** Connection refused *) + | EHOSTDOWN (** Host is down *) + | EHOSTUNREACH (** No route to host *) + | ELOOP (** Too many levels of symbolic links *) + | EOVERFLOW (** File size or position not representable *) + + | EUNKNOWNERR of int (** Unknown error *) +(** The type of error codes. + Errors defined in the POSIX standard + and additional errors from UNIX98 and BSD. + All other errors are mapped to EUNKNOWNERR. +*) + + +exception Unix_error of error * string * string +(** Raised by the system calls below when an error is encountered. + The first component is the error code; the second component + is the function name; the third component is the string parameter + to the function, if it has one, or the empty string otherwise. *) + +val error_message : error -> string +(** Return a string describing the given error code. *) + +val handle_unix_error : ('a -> 'b) -> 'a -> 'b +(** [handle_unix_error f x] applies [f] to [x] and returns the result. + If the exception [Unix_error] is raised, it prints a message + describing the error and exits with code 2. *) + + +(** {6 Access to the process environment} *) + + +val environment : unit -> string array +(** Return the process environment, as an array of strings + with the format ``variable=value''. *) + +val getenv : string -> string +(** Return the value associated to a variable in the process + environment. Raise [Not_found] if the variable is unbound. + (This function is identical to {!Sys.getenv}.) *) + +val putenv : string -> string -> unit +(** [Unix.putenv name value] sets the value associated to a + variable in the process environment. + [name] is the name of the environment variable, + and [value] its new associated value. *) + + +(** {6 Process handling} *) + + +type process_status = + WEXITED of int + (** The process terminated normally by [exit]; + the argument is the return code. *) + | WSIGNALED of int + (** The process was killed by a signal; + the argument is the signal number. *) + | WSTOPPED of int + (** The process was stopped by a signal; the argument is the + signal number. *) +(** The termination status of a process. See module {!Sys} for the + definitions of the standard signal numbers. Note that they are + not the numbers used by the OS. *) + + +type wait_flag = + WNOHANG (** do not block if no child has + died yet, but immediately return with a pid equal to 0.*) + | WUNTRACED (** report also the children that receive stop signals. *) +(** Flags for {!Unix.waitpid}. *) + +val execv : string -> string array -> 'a +(** [execv prog args] execute the program in file [prog], with + the arguments [args], and the current process environment. + These [execv*] functions never return: on success, the current + program is replaced by the new one; + on failure, a {!Unix.Unix_error} exception is raised. *) + +val execve : string -> string array -> string array -> 'a +(** Same as {!Unix.execv}, except that the third argument provides the + environment to the program executed. *) + +val execvp : string -> string array -> 'a +(** Same as {!Unix.execv}, except that + the program is searched in the path. *) + +val execvpe : string -> string array -> string array -> 'a +(** Same as {!Unix.execve}, except that + the program is searched in the path. *) + +val fork : unit -> int +(** Fork a new process. The returned integer is 0 for the child + process, the pid of the child process for the parent process. *) + +val wait : unit -> int * process_status +(** Wait until one of the children processes die, and return its pid + and termination status. *) + +val waitpid : wait_flag list -> int -> int * process_status +(** Same as {!Unix.wait}, but waits for the child process whose pid is given. + A pid of [-1] means wait for any child. + A pid of [0] means wait for any child in the same process group + as the current process. + Negative pid arguments represent process groups. + The list of options indicates whether [waitpid] should return + immediately without waiting, and whether it should report stopped + children. *) + +val system : string -> process_status +(** Execute the given command, wait until it terminates, and return + its termination status. The string is interpreted by the shell + [/bin/sh] and therefore can contain redirections, quotes, variables, + etc. The result [WEXITED 127] indicates that the shell couldn't + be executed. *) + +val getpid : unit -> int +(** Return the pid of the process. *) + +val getppid : unit -> int +(** Return the pid of the parent process. *) + +val nice : int -> int +(** Change the process priority. The integer argument is added to the + ``nice'' value. (Higher values of the ``nice'' value mean + lower priorities.) Return the new nice value. *) + + +(** {6 Basic file input/output} *) + + +type file_descr +(** The abstract type of file descriptors. *) + +val stdin : file_descr +(** File descriptor for standard input.*) + +val stdout : file_descr +(** File descriptor for standard output.*) + +val stderr : file_descr +(** File descriptor for standard error. *) + +type open_flag = + O_RDONLY (** Open for reading *) + | O_WRONLY (** Open for writing *) + | O_RDWR (** Open for reading and writing *) + | O_NONBLOCK (** Open in non-blocking mode *) + | O_APPEND (** Open for append *) + | O_CREAT (** Create if nonexistent *) + | O_TRUNC (** Truncate to 0 length if existing *) + | O_EXCL (** Fail if existing *) + | O_NOCTTY (** Don't make this dev a controlling tty *) + | O_DSYNC (** Writes complete as `Synchronised I/O data + integrity completion' *) + | O_SYNC (** Writes complete as `Synchronised I/O file + integrity completion' *) + | O_RSYNC (** Reads complete as writes (depending on + O_SYNC/O_DSYNC) *) + | O_SHARE_DELETE (** Windows only: allow the file to be deleted + while still open *) + | O_CLOEXEC (** Set the close-on-exec flag on the + descriptor returned by {!openfile} *) + +(** The flags to {!Unix.openfile}. *) + + +type file_perm = int +(** The type of file access rights, e.g. [0o640] is read and write for user, + read for group, none for others *) + +val openfile : string -> open_flag list -> file_perm -> file_descr +(** Open the named file with the given flags. Third argument is the + permissions to give to the file if it is created (see + {!umask}). Return a file descriptor on the named file. *) + +val close : file_descr -> unit +(** Close a file descriptor. *) + +val read : file_descr -> string -> int -> int -> int +(** [read fd buff ofs len] reads [len] characters from descriptor + [fd], storing them in string [buff], starting at position [ofs] + in string [buff]. Return the number of characters actually read. *) + +val write : file_descr -> string -> int -> int -> int +(** [write fd buff ofs len] writes [len] characters to descriptor + [fd], taking them from string [buff], starting at position [ofs] + in string [buff]. Return the number of characters actually + written. [write] repeats the writing operation until all characters + have been written or an error occurs. *) + +val single_write : file_descr -> string -> int -> int -> int +(** Same as [write], but attempts to write only once. + Thus, if an error occurs, [single_write] guarantees that no data + has been written. *) + +(** {6 Interfacing with the standard input/output library} *) + + + +val in_channel_of_descr : file_descr -> in_channel +(** Create an input channel reading from the given descriptor. + The channel is initially in binary mode; use + [set_binary_mode_in ic false] if text mode is desired. *) + +val out_channel_of_descr : file_descr -> out_channel +(** Create an output channel writing on the given descriptor. + The channel is initially in binary mode; use + [set_binary_mode_out oc false] if text mode is desired. *) + +val descr_of_in_channel : in_channel -> file_descr +(** Return the descriptor corresponding to an input channel. *) + +val descr_of_out_channel : out_channel -> file_descr +(** Return the descriptor corresponding to an output channel. *) + + +(** {6 Seeking and truncating} *) + + +type seek_command = + SEEK_SET (** indicates positions relative to the beginning of the file *) + | SEEK_CUR (** indicates positions relative to the current position *) + | SEEK_END (** indicates positions relative to the end of the file *) +(** Positioning modes for {!Unix.lseek}. *) + + +val lseek : file_descr -> int -> seek_command -> int +(** Set the current position for a file descriptor, and return the resulting + offset (from the beginning of the file). *) + +val truncate : string -> int -> unit +(** Truncates the named file to the given size. *) + +val ftruncate : file_descr -> int -> unit +(** Truncates the file corresponding to the given descriptor + to the given size. *) + + +(** {6 File status} *) + + +type file_kind = + S_REG (** Regular file *) + | S_DIR (** Directory *) + | S_CHR (** Character device *) + | S_BLK (** Block device *) + | S_LNK (** Symbolic link *) + | S_FIFO (** Named pipe *) + | S_SOCK (** Socket *) + +type stats = + { st_dev : int; (** Device number *) + st_ino : int; (** Inode number *) + st_kind : file_kind; (** Kind of the file *) + st_perm : file_perm; (** Access rights *) + st_nlink : int; (** Number of links *) + st_uid : int; (** User id of the owner *) + st_gid : int; (** Group ID of the file's group *) + st_rdev : int; (** Device minor number *) + st_size : int; (** Size in bytes *) + st_atime : float; (** Last access time *) + st_mtime : float; (** Last modification time *) + st_ctime : float; (** Last status change time *) + } +(** The information returned by the {!Unix.stat} calls. *) + +val stat : string -> stats +(** Return the information for the named file. *) + +val lstat : string -> stats +(** Same as {!Unix.stat}, but in case the file is a symbolic link, + return the information for the link itself. *) + +val fstat : file_descr -> stats +(** Return the information for the file associated with the given + descriptor. *) + +val isatty : file_descr -> bool +(** Return [true] if the given file descriptor refers to a terminal or + console window, [false] otherwise. *) + +(** {6 File operations on large files} *) + +module LargeFile : + sig + val lseek : file_descr -> int64 -> seek_command -> int64 + val truncate : string -> int64 -> unit + val ftruncate : file_descr -> int64 -> unit + type stats = + { st_dev : int; (** Device number *) + st_ino : int; (** Inode number *) + st_kind : file_kind; (** Kind of the file *) + st_perm : file_perm; (** Access rights *) + st_nlink : int; (** Number of links *) + st_uid : int; (** User id of the owner *) + st_gid : int; (** Group ID of the file's group *) + st_rdev : int; (** Device minor number *) + st_size : int64; (** Size in bytes *) + st_atime : float; (** Last access time *) + st_mtime : float; (** Last modification time *) + st_ctime : float; (** Last status change time *) + } + val stat : string -> stats + val lstat : string -> stats + val fstat : file_descr -> stats + end +(** File operations on large files. + This sub-module provides 64-bit variants of the functions + {!Unix.lseek} (for positioning a file descriptor), + {!Unix.truncate} and {!Unix.ftruncate} (for changing the size of a file), + and {!Unix.stat}, {!Unix.lstat} and {!Unix.fstat} (for obtaining + information on files). These alternate functions represent + positions and sizes by 64-bit integers (type [int64]) instead of + regular integers (type [int]), thus allowing operating on files + whose sizes are greater than [max_int]. *) + + +(** {6 Operations on file names} *) + + +val unlink : string -> unit +(** Removes the named file *) + +val rename : string -> string -> unit +(** [rename old new] changes the name of a file from [old] to [new]. *) + +val link : string -> string -> unit +(** [link source dest] creates a hard link named [dest] to the file + named [source]. *) + + +(** {6 File permissions and ownership} *) + + +type access_permission = + R_OK (** Read permission *) + | W_OK (** Write permission *) + | X_OK (** Execution permission *) + | F_OK (** File exists *) +(** Flags for the {!Unix.access} call. *) + + +val chmod : string -> file_perm -> unit +(** Change the permissions of the named file. *) + +val fchmod : file_descr -> file_perm -> unit +(** Change the permissions of an opened file. *) + +val chown : string -> int -> int -> unit +(** Change the owner uid and owner gid of the named file. *) + +val fchown : file_descr -> int -> int -> unit +(** Change the owner uid and owner gid of an opened file. *) + +val umask : int -> int +(** Set the process's file mode creation mask, and return the previous + mask. *) + +val access : string -> access_permission list -> unit +(** Check that the process has the given permissions over the named + file. Raise [Unix_error] otherwise. *) + + +(** {6 Operations on file descriptors} *) + + +val dup : file_descr -> file_descr +(** Return a new file descriptor referencing the same file as + the given descriptor. *) + +val dup2 : file_descr -> file_descr -> unit +(** [dup2 fd1 fd2] duplicates [fd1] to [fd2], closing [fd2] if already + opened. *) + +val set_nonblock : file_descr -> unit +(** Set the ``non-blocking'' flag on the given descriptor. + When the non-blocking flag is set, reading on a descriptor + on which there is temporarily no data available raises the + [EAGAIN] or [EWOULDBLOCK] error instead of blocking; + writing on a descriptor on which there is temporarily no room + for writing also raises [EAGAIN] or [EWOULDBLOCK]. *) + +val clear_nonblock : file_descr -> unit +(** Clear the ``non-blocking'' flag on the given descriptor. + See {!Unix.set_nonblock}.*) + +val set_close_on_exec : file_descr -> unit +(** Set the ``close-on-exec'' flag on the given descriptor. + A descriptor with the close-on-exec flag is automatically + closed when the current process starts another program with + one of the [exec] functions. *) + +val clear_close_on_exec : file_descr -> unit +(** Clear the ``close-on-exec'' flag on the given descriptor. + See {!Unix.set_close_on_exec}.*) + + +(** {6 Directories} *) + + +val mkdir : string -> file_perm -> unit +(** Create a directory with the given permissions (see {!umask}). *) + +val rmdir : string -> unit +(** Remove an empty directory. *) + +val chdir : string -> unit +(** Change the process working directory. *) + +val getcwd : unit -> string +(** Return the name of the current working directory. *) + +val chroot : string -> unit +(** Change the process root directory. *) + +type dir_handle +(** The type of descriptors over opened directories. *) + +val opendir : string -> dir_handle +(** Open a descriptor on a directory *) + +val readdir : dir_handle -> string +(** Return the next entry in a directory. + @raise End_of_file when the end of the directory has been reached. *) + +val rewinddir : dir_handle -> unit +(** Reposition the descriptor to the beginning of the directory *) + +val closedir : dir_handle -> unit +(** Close a directory descriptor. *) + + + +(** {6 Pipes and redirections} *) + + +val pipe : unit -> file_descr * file_descr +(** Create a pipe. The first component of the result is opened + for reading, that's the exit to the pipe. The second component is + opened for writing, that's the entrance to the pipe. *) + +val mkfifo : string -> file_perm -> unit +(** Create a named pipe with the given permissions (see {!umask}). *) + + +(** {6 High-level process and redirection management} *) + + +val create_process : + string -> string array -> file_descr -> file_descr -> file_descr -> int +(** [create_process prog args new_stdin new_stdout new_stderr] + forks a new process that executes the program + in file [prog], with arguments [args]. The pid of the new + process is returned immediately; the new process executes + concurrently with the current process. + The standard input and outputs of the new process are connected + to the descriptors [new_stdin], [new_stdout] and [new_stderr]. + Passing e.g. [stdout] for [new_stdout] prevents the redirection + and causes the new process to have the same standard output + as the current process. + The executable file [prog] is searched in the path. + The new process has the same environment as the current process. *) + +val create_process_env : + string -> string array -> string array -> file_descr -> file_descr -> + file_descr -> int +(** [create_process_env prog args env new_stdin new_stdout new_stderr] + works as {!Unix.create_process}, except that the extra argument + [env] specifies the environment passed to the program. *) + + +val open_process_in : string -> in_channel +(** High-level pipe and process management. This function + runs the given command in parallel with the program. + The standard output of the command is redirected to a pipe, + which can be read via the returned input channel. + The command is interpreted by the shell [/bin/sh] (cf. [system]). *) + +val open_process_out : string -> out_channel +(** Same as {!Unix.open_process_in}, but redirect the standard input of + the command to a pipe. Data written to the returned output channel + is sent to the standard input of the command. + Warning: writes on output channels are buffered, hence be careful + to call {!Pervasives.flush} at the right times to ensure + correct synchronization. *) + +val open_process : string -> in_channel * out_channel +(** Same as {!Unix.open_process_out}, but redirects both the standard input + and standard output of the command to pipes connected to the two + returned channels. The input channel is connected to the output + of the command, and the output channel to the input of the command. *) + +val open_process_full : + string -> string array -> in_channel * out_channel * in_channel +(** Similar to {!Unix.open_process}, but the second argument specifies + the environment passed to the command. The result is a triple + of channels connected respectively to the standard output, standard input, + and standard error of the command. *) + +val close_process_in : in_channel -> process_status +(** Close channels opened by {!Unix.open_process_in}, + wait for the associated command to terminate, + and return its termination status. *) + +val close_process_out : out_channel -> process_status +(** Close channels opened by {!Unix.open_process_out}, + wait for the associated command to terminate, + and return its termination status. *) + +val close_process : in_channel * out_channel -> process_status +(** Close channels opened by {!Unix.open_process}, + wait for the associated command to terminate, + and return its termination status. *) + +val close_process_full : + in_channel * out_channel * in_channel -> process_status +(** Close channels opened by {!Unix.open_process_full}, + wait for the associated command to terminate, + and return its termination status. *) + + +(** {6 Symbolic links} *) + + +val symlink : string -> string -> unit +(** [symlink source dest] creates the file [dest] as a symbolic link + to the file [source]. *) + +val readlink : string -> string +(** Read the contents of a link. *) + + +(** {6 Polling} *) + + +val select : + file_descr list -> file_descr list -> file_descr list -> float -> + file_descr list * file_descr list * file_descr list +(** Wait until some input/output operations become possible on + some channels. The three list arguments are, respectively, a set + of descriptors to check for reading (first argument), for writing + (second argument), or for exceptional conditions (third argument). + The fourth argument is the maximal timeout, in seconds; a + negative fourth argument means no timeout (unbounded wait). + The result is composed of three sets of descriptors: those ready + for reading (first component), ready for writing (second component), + and over which an exceptional condition is pending (third + component). *) + +(** {6 Locking} *) + + +type lock_command = + F_ULOCK (** Unlock a region *) + | F_LOCK (** Lock a region for writing, and block if already locked *) + | F_TLOCK (** Lock a region for writing, or fail if already locked *) + | F_TEST (** Test a region for other process locks *) + | F_RLOCK (** Lock a region for reading, and block if already locked *) + | F_TRLOCK (** Lock a region for reading, or fail if already locked *) +(** Commands for {!Unix.lockf}. *) + +val lockf : file_descr -> lock_command -> int -> unit +(** [lockf fd cmd size] puts a lock on a region of the file opened + as [fd]. The region starts at the current read/write position for + [fd] (as set by {!Unix.lseek}), and extends [size] bytes forward if + [size] is positive, [size] bytes backwards if [size] is negative, + or to the end of the file if [size] is zero. + A write lock prevents any other + process from acquiring a read or write lock on the region. + A read lock prevents any other + process from acquiring a write lock on the region, but lets + other processes acquire read locks on it. + + The [F_LOCK] and [F_TLOCK] commands attempts to put a write lock + on the specified region. + The [F_RLOCK] and [F_TRLOCK] commands attempts to put a read lock + on the specified region. + If one or several locks put by another process prevent the current process + from acquiring the lock, [F_LOCK] and [F_RLOCK] block until these locks + are removed, while [F_TLOCK] and [F_TRLOCK] fail immediately with an + exception. + The [F_ULOCK] removes whatever locks the current process has on + the specified region. + Finally, the [F_TEST] command tests whether a write lock can be + acquired on the specified region, without actually putting a lock. + It returns immediately if successful, or fails otherwise. *) + + +(** {6 Signals} + Note: installation of signal handlers is performed via + the functions {!Sys.signal} and {!Sys.set_signal}. +*) + +val kill : int -> int -> unit +(** [kill pid sig] sends signal number [sig] to the process + with id [pid]. *) + +type sigprocmask_command = + SIG_SETMASK + | SIG_BLOCK + | SIG_UNBLOCK + +val sigprocmask : sigprocmask_command -> int list -> int list +(** [sigprocmask cmd sigs] changes the set of blocked signals. + If [cmd] is [SIG_SETMASK], blocked signals are set to those in + the list [sigs]. + If [cmd] is [SIG_BLOCK], the signals in [sigs] are added to + the set of blocked signals. + If [cmd] is [SIG_UNBLOCK], the signals in [sigs] are removed + from the set of blocked signals. + [sigprocmask] returns the set of previously blocked signals. *) + +val sigpending : unit -> int list +(** Return the set of blocked signals that are currently pending. *) + +val sigsuspend : int list -> unit +(** [sigsuspend sigs] atomically sets the blocked signals to [sigs] + and waits for a non-ignored, non-blocked signal to be delivered. + On return, the blocked signals are reset to their initial value. *) + +val pause : unit -> unit +(** Wait until a non-ignored, non-blocked signal is delivered. *) + + +(** {6 Time functions} *) + + +type process_times = + { tms_utime : float; (** User time for the process *) + tms_stime : float; (** System time for the process *) + tms_cutime : float; (** User time for the children processes *) + tms_cstime : float; (** System time for the children processes *) + } +(** The execution times (CPU times) of a process. *) + +type tm = + { tm_sec : int; (** Seconds 0..60 *) + tm_min : int; (** Minutes 0..59 *) + tm_hour : int; (** Hours 0..23 *) + tm_mday : int; (** Day of month 1..31 *) + tm_mon : int; (** Month of year 0..11 *) + tm_year : int; (** Year - 1900 *) + tm_wday : int; (** Day of week (Sunday is 0) *) + tm_yday : int; (** Day of year 0..365 *) + tm_isdst : bool; (** Daylight time savings in effect *) + } +(** The type representing wallclock time and calendar date. *) + + +val time : unit -> float +(** Return the current time since 00:00:00 GMT, Jan. 1, 1970, + in seconds. *) + +val gettimeofday : unit -> float +(** Same as {!Unix.time}, but with resolution better than 1 second. *) + +val gmtime : float -> tm +(** Convert a time in seconds, as returned by {!Unix.time}, into a date and + a time. Assumes UTC (Coordinated Universal Time), also known as GMT. *) + +val localtime : float -> tm +(** Convert a time in seconds, as returned by {!Unix.time}, into a date and + a time. Assumes the local time zone. *) + +val mktime : tm -> float * tm +(** Convert a date and time, specified by the [tm] argument, into + a time in seconds, as returned by {!Unix.time}. The [tm_isdst], + [tm_wday] and [tm_yday] fields of [tm] are ignored. Also return a + normalized copy of the given [tm] record, with the [tm_wday], + [tm_yday], and [tm_isdst] fields recomputed from the other fields, + and the other fields normalized (so that, e.g., 40 October is + changed into 9 November). The [tm] argument is interpreted in the + local time zone. *) + +val alarm : int -> int +(** Schedule a [SIGALRM] signal after the given number of seconds. *) + +val sleep : int -> unit +(** Stop execution for the given number of seconds. *) + +val times : unit -> process_times +(** Return the execution times of the process. *) + +val utimes : string -> float -> float -> unit +(** Set the last access time (second arg) and last modification time + (third arg) for a file. Times are expressed in seconds from + 00:00:00 GMT, Jan. 1, 1970. A time of [0.0] is interpreted as the + current time. *) + +type interval_timer = + ITIMER_REAL + (** decrements in real time, and sends the signal [SIGALRM] when + expired.*) + | ITIMER_VIRTUAL + (** decrements in process virtual time, and sends [SIGVTALRM] + when expired. *) + | ITIMER_PROF + (** (for profiling) decrements both when the process + is running and when the system is running on behalf of the + process; it sends [SIGPROF] when expired. *) +(** The three kinds of interval timers. *) + +type interval_timer_status = + { it_interval : float; (** Period *) + it_value : float; (** Current value of the timer *) + } +(** The type describing the status of an interval timer *) + +val getitimer : interval_timer -> interval_timer_status +(** Return the current status of the given interval timer. *) + +val setitimer : + interval_timer -> interval_timer_status -> interval_timer_status +(** [setitimer t s] sets the interval timer [t] and returns + its previous status. The [s] argument is interpreted as follows: + [s.it_value], if nonzero, is the time to the next timer expiration; + [s.it_interval], if nonzero, specifies a value to + be used in reloading it_value when the timer expires. + Setting [s.it_value] to zero disable the timer. + Setting [s.it_interval] to zero causes the timer to be disabled + after its next expiration. *) + + +(** {6 User id, group id} *) + + +val getuid : unit -> int +(** Return the user id of the user executing the process. *) + +val geteuid : unit -> int +(** Return the effective user id under which the process runs. *) + +val setuid : int -> unit +(** Set the real user id and effective user id for the process. *) + +val getgid : unit -> int +(** Return the group id of the user executing the process. *) + +val getegid : unit -> int +(** Return the effective group id under which the process runs. *) + +val setgid : int -> unit +(** Set the real group id and effective group id for the process. *) + +val getgroups : unit -> int array +(** Return the list of groups to which the user executing the process + belongs. *) + +val setgroups : int array -> unit + (** [setgroups groups] sets the supplementary group IDs for the + calling process. Appropriate privileges are required. *) + +val initgroups : string -> int -> unit + (** [initgroups user group] initializes the group access list by + reading the group database /etc/group and using all groups of + which [user] is a member. The additional group [group] is also + added to the list. *) + +type passwd_entry = + { pw_name : string; + pw_passwd : string; + pw_uid : int; + pw_gid : int; + pw_gecos : string; + pw_dir : string; + pw_shell : string + } +(** Structure of entries in the [passwd] database. *) + +type group_entry = + { gr_name : string; + gr_passwd : string; + gr_gid : int; + gr_mem : string array + } +(** Structure of entries in the [groups] database. *) + +val getlogin : unit -> string +(** Return the login name of the user executing the process. *) + +val getpwnam : string -> passwd_entry +(** Find an entry in [passwd] with the given name, or raise + [Not_found]. *) + +val getgrnam : string -> group_entry +(** Find an entry in [group] with the given name, or raise + [Not_found]. *) + +val getpwuid : int -> passwd_entry +(** Find an entry in [passwd] with the given user id, or raise + [Not_found]. *) + +val getgrgid : int -> group_entry +(** Find an entry in [group] with the given group id, or raise + [Not_found]. *) + + +(** {6 Internet addresses} *) + + +type inet_addr +(** The abstract type of Internet addresses. *) + +val inet_addr_of_string : string -> inet_addr +(** Conversion from the printable representation of an Internet + address to its internal representation. The argument string + consists of 4 numbers separated by periods ([XXX.YYY.ZZZ.TTT]) + for IPv4 addresses, and up to 8 numbers separated by colons + for IPv6 addresses. Raise [Failure] when given a string that + does not match these formats. *) + +val string_of_inet_addr : inet_addr -> string +(** Return the printable representation of the given Internet address. + See {!Unix.inet_addr_of_string} for a description of the + printable representation. *) + +val inet_addr_any : inet_addr +(** A special IPv4 address, for use only with [bind], representing + all the Internet addresses that the host machine possesses. *) + +val inet_addr_loopback : inet_addr +(** A special IPv4 address representing the host machine ([127.0.0.1]). *) + +val inet6_addr_any : inet_addr +(** A special IPv6 address, for use only with [bind], representing + all the Internet addresses that the host machine possesses. *) + +val inet6_addr_loopback : inet_addr +(** A special IPv6 address representing the host machine ([::1]). *) + + +(** {6 Sockets} *) + + +type socket_domain = + PF_UNIX (** Unix domain *) + | PF_INET (** Internet domain (IPv4) *) + | PF_INET6 (** Internet domain (IPv6) *) +(** The type of socket domains. Not all platforms support + IPv6 sockets (type [PF_INET6]). *) + +type socket_type = + SOCK_STREAM (** Stream socket *) + | SOCK_DGRAM (** Datagram socket *) + | SOCK_RAW (** Raw socket *) + | SOCK_SEQPACKET (** Sequenced packets socket *) +(** The type of socket kinds, specifying the semantics of + communications. *) + +type sockaddr = + ADDR_UNIX of string + | ADDR_INET of inet_addr * int +(** The type of socket addresses. [ADDR_UNIX name] is a socket + address in the Unix domain; [name] is a file name in the file + system. [ADDR_INET(addr,port)] is a socket address in the Internet + domain; [addr] is the Internet address of the machine, and + [port] is the port number. *) + +val socket : socket_domain -> socket_type -> int -> file_descr +(** Create a new socket in the given domain, and with the + given kind. The third argument is the protocol type; 0 selects + the default protocol for that kind of sockets. *) + +val domain_of_sockaddr: sockaddr -> socket_domain +(** Return the socket domain adequate for the given socket address. *) + +val socketpair : + socket_domain -> socket_type -> int -> file_descr * file_descr +(** Create a pair of unnamed sockets, connected together. *) + +val accept : file_descr -> file_descr * sockaddr +(** Accept connections on the given socket. The returned descriptor + is a socket connected to the client; the returned address is + the address of the connecting client. *) + +val bind : file_descr -> sockaddr -> unit +(** Bind a socket to an address. *) + +val connect : file_descr -> sockaddr -> unit +(** Connect a socket to an address. *) + +val listen : file_descr -> int -> unit +(** Set up a socket for receiving connection requests. The integer + argument is the maximal number of pending requests. *) + +type shutdown_command = + SHUTDOWN_RECEIVE (** Close for receiving *) + | SHUTDOWN_SEND (** Close for sending *) + | SHUTDOWN_ALL (** Close both *) +(** The type of commands for [shutdown]. *) + + +val shutdown : file_descr -> shutdown_command -> unit +(** Shutdown a socket connection. [SHUTDOWN_SEND] as second argument + causes reads on the other end of the connection to return + an end-of-file condition. + [SHUTDOWN_RECEIVE] causes writes on the other end of the connection + to return a closed pipe condition ([SIGPIPE] signal). *) + +val getsockname : file_descr -> sockaddr +(** Return the address of the given socket. *) + +val getpeername : file_descr -> sockaddr +(** Return the address of the host connected to the given socket. *) + +type msg_flag = + MSG_OOB + | MSG_DONTROUTE + | MSG_PEEK +(** The flags for {!Unix.recv}, {!Unix.recvfrom}, + {!Unix.send} and {!Unix.sendto}. *) + +val recv : file_descr -> string -> int -> int -> msg_flag list -> int +(** Receive data from a connected socket. *) + +val recvfrom : + file_descr -> string -> int -> int -> msg_flag list -> int * sockaddr +(** Receive data from an unconnected socket. *) + +val send : file_descr -> string -> int -> int -> msg_flag list -> int +(** Send data over a connected socket. *) + +val sendto : + file_descr -> string -> int -> int -> msg_flag list -> sockaddr -> int +(** Send data over an unconnected socket. *) + + + +(** {6 Socket options} *) + + +type socket_bool_option = + SO_DEBUG (** Record debugging information *) + | SO_BROADCAST (** Permit sending of broadcast messages *) + | SO_REUSEADDR (** Allow reuse of local addresses for bind *) + | SO_KEEPALIVE (** Keep connection active *) + | SO_DONTROUTE (** Bypass the standard routing algorithms *) + | SO_OOBINLINE (** Leave out-of-band data in line *) + | SO_ACCEPTCONN (** Report whether socket listening is enabled *) + | TCP_NODELAY (** Control the Nagle algorithm for TCP sockets *) + | IPV6_ONLY (** Forbid binding an IPv6 socket to an IPv4 address *) +(** The socket options that can be consulted with {!Unix.getsockopt} + and modified with {!Unix.setsockopt}. These options have a boolean + ([true]/[false]) value. *) + +type socket_int_option = + SO_SNDBUF (** Size of send buffer *) + | SO_RCVBUF (** Size of received buffer *) + | SO_ERROR (** Deprecated. Use {!Unix.getsockopt_error} instead. *) + | SO_TYPE (** Report the socket type *) + | SO_RCVLOWAT (** Minimum number of bytes to process for input operations*) + | SO_SNDLOWAT (** Minimum number of bytes to process for output + operations *) +(** The socket options that can be consulted with {!Unix.getsockopt_int} + and modified with {!Unix.setsockopt_int}. These options have an + integer value. *) + +type socket_optint_option = + SO_LINGER (** Whether to linger on closed connections + that have data present, and for how long + (in seconds) *) +(** The socket options that can be consulted with {!Unix.getsockopt_optint} + and modified with {!Unix.setsockopt_optint}. These options have a + value of type [int option], with [None] meaning ``disabled''. *) + +type socket_float_option = + SO_RCVTIMEO (** Timeout for input operations *) + | SO_SNDTIMEO (** Timeout for output operations *) +(** The socket options that can be consulted with {!Unix.getsockopt_float} + and modified with {!Unix.setsockopt_float}. These options have a + floating-point value representing a time in seconds. + The value 0 means infinite timeout. *) + +val getsockopt : file_descr -> socket_bool_option -> bool +(** Return the current status of a boolean-valued option + in the given socket. *) + +val setsockopt : file_descr -> socket_bool_option -> bool -> unit +(** Set or clear a boolean-valued option in the given socket. *) + +val getsockopt_int : file_descr -> socket_int_option -> int +(** Same as {!Unix.getsockopt} for an integer-valued socket option. *) + +val setsockopt_int : file_descr -> socket_int_option -> int -> unit +(** Same as {!Unix.setsockopt} for an integer-valued socket option. *) + +val getsockopt_optint : file_descr -> socket_optint_option -> int option +(** Same as {!Unix.getsockopt} for a socket option whose value is an + [int option]. *) + +val setsockopt_optint : + file_descr -> socket_optint_option -> int option -> unit +(** Same as {!Unix.setsockopt} for a socket option whose value is an + [int option]. *) + +val getsockopt_float : file_descr -> socket_float_option -> float +(** Same as {!Unix.getsockopt} for a socket option whose value is a + floating-point number. *) + +val setsockopt_float : file_descr -> socket_float_option -> float -> unit +(** Same as {!Unix.setsockopt} for a socket option whose value is a + floating-point number. *) + +val getsockopt_error : file_descr -> error option +(** Return the error condition associated with the given socket, + and clear it. *) + +(** {6 High-level network connection functions} *) + + +val open_connection : sockaddr -> in_channel * out_channel +(** Connect to a server at the given address. + Return a pair of buffered channels connected to the server. + Remember to call {!Pervasives.flush} on the output channel at the right + times to ensure correct synchronization. *) + +val shutdown_connection : in_channel -> unit +(** ``Shut down'' a connection established with {!Unix.open_connection}; + that is, transmit an end-of-file condition to the server reading + on the other side of the connection. *) + +val establish_server : (in_channel -> out_channel -> unit) -> sockaddr -> unit +(** Establish a server on the given address. + The function given as first argument is called for each connection + with two buffered channels connected to the client. A new process + is created for each connection. The function {!Unix.establish_server} + never returns normally. *) + + +(** {6 Host and protocol databases} *) + + +type host_entry = + { h_name : string; + h_aliases : string array; + h_addrtype : socket_domain; + h_addr_list : inet_addr array + } +(** Structure of entries in the [hosts] database. *) + +type protocol_entry = + { p_name : string; + p_aliases : string array; + p_proto : int + } +(** Structure of entries in the [protocols] database. *) + +type service_entry = + { s_name : string; + s_aliases : string array; + s_port : int; + s_proto : string + } +(** Structure of entries in the [services] database. *) + +val gethostname : unit -> string +(** Return the name of the local host. *) + +val gethostbyname : string -> host_entry +(** Find an entry in [hosts] with the given name, or raise + [Not_found]. *) + +val gethostbyaddr : inet_addr -> host_entry +(** Find an entry in [hosts] with the given address, or raise + [Not_found]. *) + +val getprotobyname : string -> protocol_entry +(** Find an entry in [protocols] with the given name, or raise + [Not_found]. *) + +val getprotobynumber : int -> protocol_entry +(** Find an entry in [protocols] with the given protocol number, + or raise [Not_found]. *) + +val getservbyname : string -> string -> service_entry +(** Find an entry in [services] with the given name, or raise + [Not_found]. *) + +val getservbyport : int -> string -> service_entry +(** Find an entry in [services] with the given service number, + or raise [Not_found]. *) + +type addr_info = + { ai_family : socket_domain; (** Socket domain *) + ai_socktype : socket_type; (** Socket type *) + ai_protocol : int; (** Socket protocol number *) + ai_addr : sockaddr; (** Address *) + ai_canonname : string (** Canonical host name *) + } +(** Address information returned by {!Unix.getaddrinfo}. *) + +type getaddrinfo_option = + AI_FAMILY of socket_domain (** Impose the given socket domain *) + | AI_SOCKTYPE of socket_type (** Impose the given socket type *) + | AI_PROTOCOL of int (** Impose the given protocol *) + | AI_NUMERICHOST (** Do not call name resolver, + expect numeric IP address *) + | AI_CANONNAME (** Fill the [ai_canonname] field + of the result *) + | AI_PASSIVE (** Set address to ``any'' address + for use with {!Unix.bind} *) +(** Options to {!Unix.getaddrinfo}. *) + +val getaddrinfo: + string -> string -> getaddrinfo_option list -> addr_info list +(** [getaddrinfo host service opts] returns a list of {!Unix.addr_info} + records describing socket parameters and addresses suitable for + communicating with the given host and service. The empty list is + returned if the host or service names are unknown, or the constraints + expressed in [opts] cannot be satisfied. + + [host] is either a host name or the string representation of an IP + address. [host] can be given as the empty string; in this case, + the ``any'' address or the ``loopback'' address are used, + depending whether [opts] contains [AI_PASSIVE]. + [service] is either a service name or the string representation of + a port number. [service] can be given as the empty string; + in this case, the port field of the returned addresses is set to 0. + [opts] is a possibly empty list of options that allows the caller + to force a particular socket domain (e.g. IPv6 only or IPv4 only) + or a particular socket type (e.g. TCP only or UDP only). *) + +type name_info = + { ni_hostname : string; (** Name or IP address of host *) + ni_service : string } (** Name of service or port number *) +(** Host and service information returned by {!Unix.getnameinfo}. *) + +type getnameinfo_option = + NI_NOFQDN (** Do not qualify local host names *) + | NI_NUMERICHOST (** Always return host as IP address *) + | NI_NAMEREQD (** Fail if host name cannot be determined *) + | NI_NUMERICSERV (** Always return service as port number *) + | NI_DGRAM (** Consider the service as UDP-based + instead of the default TCP *) +(** Options to {!Unix.getnameinfo}. *) + +val getnameinfo : sockaddr -> getnameinfo_option list -> name_info +(** [getnameinfo addr opts] returns the host name and service name + corresponding to the socket address [addr]. [opts] is a possibly + empty list of options that governs how these names are obtained. + Raise [Not_found] if an error occurs. *) + + +(** {6 Terminal interface} *) + + +(** The following functions implement the POSIX standard terminal + interface. They provide control over asynchronous communication ports + and pseudo-terminals. Refer to the [termios] man page for a + complete description. *) + +type terminal_io = + { + (* input modes *) + mutable c_ignbrk : bool; (** Ignore the break condition. *) + mutable c_brkint : bool; (** Signal interrupt on break condition. *) + mutable c_ignpar : bool; (** Ignore characters with parity errors. *) + mutable c_parmrk : bool; (** Mark parity errors. *) + mutable c_inpck : bool; (** Enable parity check on input. *) + mutable c_istrip : bool; (** Strip 8th bit on input characters. *) + mutable c_inlcr : bool; (** Map NL to CR on input. *) + mutable c_igncr : bool; (** Ignore CR on input. *) + mutable c_icrnl : bool; (** Map CR to NL on input. *) + mutable c_ixon : bool; (** Recognize XON/XOFF characters on input. *) + mutable c_ixoff : bool; (** Emit XON/XOFF chars to control input flow. *) + (* Output modes: *) + mutable c_opost : bool; (** Enable output processing. *) + (* Control modes: *) + mutable c_obaud : int; (** Output baud rate (0 means close connection).*) + mutable c_ibaud : int; (** Input baud rate. *) + mutable c_csize : int; (** Number of bits per character (5-8). *) + mutable c_cstopb : int; (** Number of stop bits (1-2). *) + mutable c_cread : bool; (** Reception is enabled. *) + mutable c_parenb : bool; (** Enable parity generation and detection. *) + mutable c_parodd : bool; (** Specify odd parity instead of even. *) + mutable c_hupcl : bool; (** Hang up on last close. *) + mutable c_clocal : bool; (** Ignore modem status lines. *) + (* Local modes: *) + mutable c_isig : bool; (** Generate signal on INTR, QUIT, SUSP. *) + mutable c_icanon : bool; (** Enable canonical processing + (line buffering and editing) *) + mutable c_noflsh : bool; (** Disable flush after INTR, QUIT, SUSP. *) + mutable c_echo : bool; (** Echo input characters. *) + mutable c_echoe : bool; (** Echo ERASE (to erase previous character). *) + mutable c_echok : bool; (** Echo KILL (to erase the current line). *) + mutable c_echonl : bool; (** Echo NL even if c_echo is not set. *) + (* Control characters: *) + mutable c_vintr : char; (** Interrupt character (usually ctrl-C). *) + mutable c_vquit : char; (** Quit character (usually ctrl-\). *) + mutable c_verase : char; (** Erase character (usually DEL or ctrl-H). *) + mutable c_vkill : char; (** Kill line character (usually ctrl-U). *) + mutable c_veof : char; (** End-of-file character (usually ctrl-D). *) + mutable c_veol : char; (** Alternate end-of-line char. (usually none). *) + mutable c_vmin : int; (** Minimum number of characters to read + before the read request is satisfied. *) + mutable c_vtime : int; (** Maximum read wait (in 0.1s units). *) + mutable c_vstart : char; (** Start character (usually ctrl-Q). *) + mutable c_vstop : char; (** Stop character (usually ctrl-S). *) + } + +val tcgetattr : file_descr -> terminal_io +(** Return the status of the terminal referred to by the given + file descriptor. *) + +type setattr_when = + TCSANOW + | TCSADRAIN + | TCSAFLUSH + +val tcsetattr : file_descr -> setattr_when -> terminal_io -> unit +(** Set the status of the terminal referred to by the given + file descriptor. The second argument indicates when the + status change takes place: immediately ([TCSANOW]), + when all pending output has been transmitted ([TCSADRAIN]), + or after flushing all input that has been received but not + read ([TCSAFLUSH]). [TCSADRAIN] is recommended when changing + the output parameters; [TCSAFLUSH], when changing the input + parameters. *) + +val tcsendbreak : file_descr -> int -> unit +(** Send a break condition on the given file descriptor. + The second argument is the duration of the break, in 0.1s units; + 0 means standard duration (0.25s). *) + +val tcdrain : file_descr -> unit +(** Waits until all output written on the given file descriptor + has been transmitted. *) + +type flush_queue = + TCIFLUSH + | TCOFLUSH + | TCIOFLUSH + +val tcflush : file_descr -> flush_queue -> unit +(** Discard data written on the given file descriptor but not yet + transmitted, or data received but not yet read, depending on the + second argument: [TCIFLUSH] flushes data received but not read, + [TCOFLUSH] flushes data written but not transmitted, and + [TCIOFLUSH] flushes both. *) + +type flow_action = + TCOOFF + | TCOON + | TCIOFF + | TCION + +val tcflow : file_descr -> flow_action -> unit +(** Suspend or restart reception or transmission of data on + the given file descriptor, depending on the second argument: + [TCOOFF] suspends output, [TCOON] restarts output, + [TCIOFF] transmits a STOP character to suspend input, + and [TCION] transmits a START character to restart input. *) + +val setsid : unit -> int +(** Put the calling process in a new session and detach it from + its controlling terminal. *) diff --git a/cst2constr.c b/cst2constr.c new file mode 100644 index 0000000..87721ce --- /dev/null +++ b/cst2constr.c @@ -0,0 +1,24 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../../LICENSE. */ +/* */ +/***********************************************************************/ + +#include +#include +#include "cst2constr.h" + +value cst_to_constr(int n, int *tbl, int size, int deflt) +{ + int i; + for (i = 0; i < size; i++) + if (n == tbl[i]) return Val_int(i); + return Val_int(deflt); +} diff --git a/cst2constr.h b/cst2constr.h new file mode 100644 index 0000000..88985e5 --- /dev/null +++ b/cst2constr.h @@ -0,0 +1,14 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../../LICENSE. */ +/* */ +/***********************************************************************/ + +extern value cst_to_constr(int n, int * tbl, int size, int deflt); diff --git a/gettimeofday.c b/gettimeofday.c new file mode 100644 index 0000000..9cbfbea --- /dev/null +++ b/gettimeofday.c @@ -0,0 +1,36 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../../LICENSE. */ +/* */ +/***********************************************************************/ + +#include +#include +#include +#include "unixsupport.h" + +#ifdef HAS_GETTIMEOFDAY + +#include +#include + +CAMLprim value unix_gettimeofday(value unit) +{ + struct timeval tp; + if (gettimeofday(&tp, NULL) == -1) uerror("gettimeofday", Nothing); + return copy_double((double) tp.tv_sec + (double) tp.tv_usec / 1e6); +} + +#else + +CAMLprim value unix_gettimeofday(value unit) +{ invalid_argument("gettimeofday not implemented"); } + +#endif diff --git a/gmtime.c b/gmtime.c new file mode 100644 index 0000000..566f174 --- /dev/null +++ b/gmtime.c @@ -0,0 +1,93 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../../LICENSE. */ +/* */ +/***********************************************************************/ + +#include +#include +#include +#include +#include "unixsupport.h" +#include +#include + +static value alloc_tm(struct tm *tm) +{ + value res; + res = alloc_small(9, 0); + Field(res,0) = Val_int(tm->tm_sec); + Field(res,1) = Val_int(tm->tm_min); + Field(res,2) = Val_int(tm->tm_hour); + Field(res,3) = Val_int(tm->tm_mday); + Field(res,4) = Val_int(tm->tm_mon); + Field(res,5) = Val_int(tm->tm_year); + Field(res,6) = Val_int(tm->tm_wday); + Field(res,7) = Val_int(tm->tm_yday); + Field(res,8) = tm->tm_isdst ? Val_true : Val_false; + return res; +} + +CAMLprim value unix_gmtime(value t) +{ + time_t clock; + struct tm * tm; + clock = (time_t) Double_val(t); + tm = gmtime(&clock); + if (tm == NULL) unix_error(EINVAL, "gmtime", Nothing); + return alloc_tm(tm); +} + +CAMLprim value unix_localtime(value t) +{ + time_t clock; + struct tm * tm; + clock = (time_t) Double_val(t); + tm = localtime(&clock); + if (tm == NULL) unix_error(EINVAL, "localtime", Nothing); + return alloc_tm(tm); +} + +#ifdef HAS_MKTIME + +CAMLprim value unix_mktime(value t) +{ + struct tm tm; + time_t clock; + value res; + value tmval = Val_unit, clkval = Val_unit; + + Begin_roots2(tmval, clkval); + tm.tm_sec = Int_val(Field(t, 0)); + tm.tm_min = Int_val(Field(t, 1)); + tm.tm_hour = Int_val(Field(t, 2)); + tm.tm_mday = Int_val(Field(t, 3)); + tm.tm_mon = Int_val(Field(t, 4)); + tm.tm_year = Int_val(Field(t, 5)); + tm.tm_wday = Int_val(Field(t, 6)); + tm.tm_yday = Int_val(Field(t, 7)); + tm.tm_isdst = -1; /* tm.tm_isdst = Bool_val(Field(t, 8)); */ + clock = mktime(&tm); + if (clock == (time_t) -1) unix_error(ERANGE, "mktime", Nothing); + tmval = alloc_tm(&tm); + clkval = copy_double((double) clock); + res = alloc_small(2, 0); + Field(res, 0) = clkval; + Field(res, 1) = tmval; + End_roots (); + return res; +} + +#else + +CAMLprim value unix_mktime(value t) +{ invalid_argument("mktime not implemented"); } + +#endif diff --git a/unixsupport.c b/unixsupport.c new file mode 100644 index 0000000..6c7171f --- /dev/null +++ b/unixsupport.c @@ -0,0 +1,309 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../../LICENSE. */ +/* */ +/***********************************************************************/ + +#include +#include +#include +#include +#include +#include "unixsupport.h" +#include "cst2constr.h" +#include + +#ifndef E2BIG +#define E2BIG (-1) +#endif +#ifndef EACCES +#define EACCES (-1) +#endif +#ifndef EAGAIN +#define EAGAIN (-1) +#endif +#ifndef EBADF +#define EBADF (-1) +#endif +#ifndef EBUSY +#define EBUSY (-1) +#endif +#ifndef ECHILD +#define ECHILD (-1) +#endif +#ifndef EDEADLK +#define EDEADLK (-1) +#endif +#ifndef EDOM +#define EDOM (-1) +#endif +#ifndef EEXIST +#define EEXIST (-1) +#endif + +#ifndef EFAULT +#define EFAULT (-1) +#endif +#ifndef EFBIG +#define EFBIG (-1) +#endif +#ifndef EINTR +#define EINTR (-1) +#endif +#ifndef EINVAL +#define EINVAL (-1) +#endif +#ifndef EIO +#define EIO (-1) +#endif +#ifndef EISDIR +#define EISDIR (-1) +#endif +#ifndef EMFILE +#define EMFILE (-1) +#endif +#ifndef EMLINK +#define EMLINK (-1) +#endif +#ifndef ENAMETOOLONG +#define ENAMETOOLONG (-1) +#endif +#ifndef ENFILE +#define ENFILE (-1) +#endif +#ifndef ENODEV +#define ENODEV (-1) +#endif +#ifndef ENOENT +#define ENOENT (-1) +#endif +#ifndef ENOEXEC +#define ENOEXEC (-1) +#endif +#ifndef ENOLCK +#define ENOLCK (-1) +#endif +#ifndef ENOMEM +#define ENOMEM (-1) +#endif +#ifndef ENOSPC +#define ENOSPC (-1) +#endif +#ifndef ENOSYS +#define ENOSYS (-1) +#endif +#ifndef ENOTDIR +#define ENOTDIR (-1) +#endif +#ifndef ENOTEMPTY +#define ENOTEMPTY (-1) +#endif +#ifndef ENOTTY +#define ENOTTY (-1) +#endif +#ifndef ENXIO +#define ENXIO (-1) +#endif +#ifndef EPERM +#define EPERM (-1) +#endif +#ifndef EPIPE +#define EPIPE (-1) +#endif +#ifndef ERANGE +#define ERANGE (-1) +#endif +#ifndef EROFS +#define EROFS (-1) +#endif +#ifndef ESPIPE +#define ESPIPE (-1) +#endif +#ifndef ESRCH +#define ESRCH (-1) +#endif +#ifndef EXDEV +#define EXDEV (-1) +#endif +#ifndef EWOULDBLOCK +#define EWOULDBLOCK (-1) +#endif +#ifndef EINPROGRESS +#define EINPROGRESS (-1) +#endif +#ifndef EALREADY +#define EALREADY (-1) +#endif +#ifndef ENOTSOCK +#define ENOTSOCK (-1) +#endif +#ifndef EDESTADDRREQ +#define EDESTADDRREQ (-1) +#endif +#ifndef EMSGSIZE +#define EMSGSIZE (-1) +#endif +#ifndef EPROTOTYPE +#define EPROTOTYPE (-1) +#endif +#ifndef ENOPROTOOPT +#define ENOPROTOOPT (-1) +#endif +#ifndef EPROTONOSUPPORT +#define EPROTONOSUPPORT (-1) +#endif +#ifndef ESOCKTNOSUPPORT +#define ESOCKTNOSUPPORT (-1) +#endif +#ifndef EOPNOTSUPP +# ifdef ENOTSUP +# define EOPNOTSUPP ENOTSUP +# else +# define EOPNOTSUPP (-1) +# endif +#endif +#ifndef EPFNOSUPPORT +#define EPFNOSUPPORT (-1) +#endif +#ifndef EAFNOSUPPORT +#define EAFNOSUPPORT (-1) +#endif +#ifndef EADDRINUSE +#define EADDRINUSE (-1) +#endif +#ifndef EADDRNOTAVAIL +#define EADDRNOTAVAIL (-1) +#endif +#ifndef ENETDOWN +#define ENETDOWN (-1) +#endif +#ifndef ENETUNREACH +#define ENETUNREACH (-1) +#endif +#ifndef ENETRESET +#define ENETRESET (-1) +#endif +#ifndef ECONNABORTED +#define ECONNABORTED (-1) +#endif +#ifndef ECONNRESET +#define ECONNRESET (-1) +#endif +#ifndef ENOBUFS +#define ENOBUFS (-1) +#endif +#ifndef EISCONN +#define EISCONN (-1) +#endif +#ifndef ENOTCONN +#define ENOTCONN (-1) +#endif +#ifndef ESHUTDOWN +#define ESHUTDOWN (-1) +#endif +#ifndef ETOOMANYREFS +#define ETOOMANYREFS (-1) +#endif +#ifndef ETIMEDOUT +#define ETIMEDOUT (-1) +#endif +#ifndef ECONNREFUSED +#define ECONNREFUSED (-1) +#endif +#ifndef EHOSTDOWN +#define EHOSTDOWN (-1) +#endif +#ifndef EHOSTUNREACH +#define EHOSTUNREACH (-1) +#endif +#ifndef ENOTEMPTY +#define ENOTEMPTY (-1) +#endif +#ifndef ELOOP +#define ELOOP (-1) +#endif +#ifndef EOVERFLOW +#define EOVERFLOW (-1) +#endif + +int error_table[] = { + E2BIG, EACCES, EAGAIN, EBADF, EBUSY, ECHILD, EDEADLK, EDOM, + EEXIST, EFAULT, EFBIG, EINTR, EINVAL, EIO, EISDIR, EMFILE, EMLINK, + ENAMETOOLONG, ENFILE, ENODEV, ENOENT, ENOEXEC, ENOLCK, ENOMEM, ENOSPC, + ENOSYS, ENOTDIR, ENOTEMPTY, ENOTTY, ENXIO, EPERM, EPIPE, ERANGE, + EROFS, ESPIPE, ESRCH, EXDEV, EWOULDBLOCK, EINPROGRESS, EALREADY, + ENOTSOCK, EDESTADDRREQ, EMSGSIZE, EPROTOTYPE, ENOPROTOOPT, + EPROTONOSUPPORT, ESOCKTNOSUPPORT, EOPNOTSUPP, EPFNOSUPPORT, + EAFNOSUPPORT, EADDRINUSE, EADDRNOTAVAIL, ENETDOWN, ENETUNREACH, + ENETRESET, ECONNABORTED, ECONNRESET, ENOBUFS, EISCONN, ENOTCONN, + ESHUTDOWN, ETOOMANYREFS, ETIMEDOUT, ECONNREFUSED, EHOSTDOWN, + EHOSTUNREACH, ELOOP, EOVERFLOW /*, EUNKNOWNERR */ +}; + +static value * unix_error_exn = NULL; + +value unix_error_of_code (int errcode) +{ + int errconstr; + value err; + +#if defined(ENOTSUP) && (EOPNOTSUPP != ENOTSUP) + if (errcode == ENOTSUP) + errcode = EOPNOTSUPP; +#endif + + errconstr = + cst_to_constr(errcode, error_table, sizeof(error_table)/sizeof(int), -1); + if (errconstr == Val_int(-1)) { + err = alloc_small(1, 0); + Field(err, 0) = Val_int(errcode); + } else { + err = errconstr; + } + return err; +} + +extern int code_of_unix_error (value error) +{ + if (Is_block(error)) { + return Int_val(Field(error, 0)); + } else { + return error_table[Int_val(error)]; + } +} + +void unix_error(int errcode, char *cmdname, value cmdarg) +{ + value res; + value name = Val_unit, err = Val_unit, arg = Val_unit; + + Begin_roots3 (name, err, arg); + arg = cmdarg == Nothing ? copy_string("") : cmdarg; + name = copy_string(cmdname); + err = unix_error_of_code (errcode); + if (unix_error_exn == NULL) { + unix_error_exn = caml_named_value("Unix.Unix_error"); + if (unix_error_exn == NULL) + invalid_argument("Exception Unix.Unix_error not initialized," + " please link unix.cma"); + } + res = alloc_small(4, 0); + Field(res, 0) = *unix_error_exn; + Field(res, 1) = err; + Field(res, 2) = name; + Field(res, 3) = arg; + End_roots(); + mlraise(res); +} + +void uerror(char *cmdname, value cmdarg) +{ + unix_error(errno, cmdname, cmdarg); +} diff --git a/unixsupport.h b/unixsupport.h new file mode 100644 index 0000000..a8065d9 --- /dev/null +++ b/unixsupport.h @@ -0,0 +1,27 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../../LICENSE. */ +/* */ +/***********************************************************************/ + +#ifdef HAS_UNISTD +#include +#endif + +#define Nothing ((value) 0) + +extern value unix_error_of_code (int errcode); +extern int code_of_unix_error (value error); +extern void unix_error (int errcode, char * cmdname, value arg) Noreturn; +extern void uerror (char * cmdname, value arg) Noreturn; + +#define UNIX_BUFFER_SIZE 65536 + +#define DIR_Val(v) *((DIR **) &Field(v, 0))