diff options
Diffstat (limited to 'ocaml-binary-annot/otherlibs/win32unix')
50 files changed, 5290 insertions, 0 deletions
diff --git a/ocaml-binary-annot/otherlibs/win32unix/.cvsignore b/ocaml-binary-annot/otherlibs/win32unix/.cvsignore new file mode 100644 index 0000000000..e85bbd9af2 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/.cvsignore @@ -0,0 +1,27 @@ +unixLabels.ml* +unix.mli +unix.lib +access.c +addrofstr.c +chdir.c +chmod.c +cst2constr.c +cstringv.c +envir.c +execv.c +execve.c +execvp.c +exit.c +getcwd.c +gethost.c +gethostname.c +getproto.c +getserv.c +gmtime.c +putenv.c +rmdir.c +socketaddr.c +strofaddr.c +time.c +unlink.c +utimes.c diff --git a/ocaml-binary-annot/otherlibs/win32unix/.depend b/ocaml-binary-annot/otherlibs/win32unix/.depend new file mode 100644 index 0000000000..a608240cdf --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/.depend @@ -0,0 +1,5 @@ +unix.cmo: unix.cmi +unix.cmx: unix.cmi +unixLabels.cmo: unix.cmi unixLabels.cmi +unixLabels.cmx: unix.cmx unixLabels.cmi +unixLabels.cmi: unix.cmi diff --git a/ocaml-binary-annot/otherlibs/win32unix/Makefile.nt b/ocaml-binary-annot/otherlibs/win32unix/Makefile.nt new file mode 100644 index 0000000000..0d98b31695 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/Makefile.nt @@ -0,0 +1,61 @@ +######################################################################### +# # +# Objective Caml # +# # +# Xavier Leroy, projet Cristal, INRIA Rocquencourt # +# # +# Copyright 1999 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. # +# # +######################################################################### + +# $Id$ + +# Files in this directory +WIN_FILES = accept.c bind.c channels.c close.c \ + close_on.c connect.c createprocess.c dup.c dup2.c errmsg.c \ + getpeername.c getpid.c getsockname.c gettimeofday.c \ + link.c listen.c lockf.c lseek.c nonblock.c \ + mkdir.c open.c pipe.c read.c rename.c \ + select.c sendrecv.c \ + shutdown.c sleep.c socket.c sockopt.c startup.c stat.c \ + system.c unixsupport.c windir.c winwait.c write.c \ + winlist.c winworker.c windbug.c + +# Files from the ../unix directory +UNIX_FILES = access.c addrofstr.c chdir.c chmod.c cst2constr.c \ + cstringv.c envir.c execv.c execve.c execvp.c \ + exit.c getcwd.c gethost.c gethostname.c getproto.c \ + getserv.c gmtime.c putenv.c rmdir.c \ + socketaddr.c strofaddr.c time.c unlink.c utimes.c + +UNIX_CAML_FILES = unix.mli unixLabels.mli unixLabels.ml + +ALL_FILES=$(WIN_FILES) $(UNIX_FILES) +WSOCKLIB=$(call SYSLIB,ws2_32) + +LIBNAME=unix +COBJS=$(ALL_FILES:.c=.$(O)) +CAMLOBJS=unix.cmo unixLabels.cmo +LINKOPTS=-cclib $(WSOCKLIB) +LDOPTS=-ldopt $(WSOCKLIB) +EXTRACAMLFLAGS=-nolabels +EXTRACFLAGS=-I../unix +HEADERS=unixsupport.h socketaddr.h + + +include ../Makefile.nt + +clean:: + rm -f $(UNIX_FILES) $(UNIX_CAML_FILES) + +$(UNIX_FILES) $(UNIX_CAML_FILES): %: ../unix/% + cp ../unix/$* $* + +depend: + +$(COBJS): unixsupport.h + +include .depend diff --git a/ocaml-binary-annot/otherlibs/win32unix/accept.c b/ocaml-binary-annot/otherlibs/win32unix/accept.c new file mode 100644 index 0000000000..1d54b89b32 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/accept.c @@ -0,0 +1,65 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <mlvalues.h> +#include <alloc.h> +#include <memory.h> +#include <signals.h> +#include "unixsupport.h" +#include "socketaddr.h" + +CAMLprim value unix_accept(sock) + value sock; +{ + SOCKET sconn = Socket_val(sock); + SOCKET snew; + value fd = Val_unit, adr = Val_unit, res; + int oldvalue, oldvaluelen, newvalue, retcode; + union sock_addr_union addr; + socklen_param_type addr_len; + DWORD err = 0; + + oldvaluelen = sizeof(oldvalue); + retcode = getsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, + (char *) &oldvalue, &oldvaluelen); + if (retcode == 0) { + /* Set sockets to synchronous mode */ + newvalue = SO_SYNCHRONOUS_NONALERT; + setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, + (char *) &newvalue, sizeof(newvalue)); + } + addr_len = sizeof(sock_addr); + enter_blocking_section(); + snew = accept(sconn, &addr.s_gen, &addr_len); + if (snew == INVALID_SOCKET) err = WSAGetLastError (); + leave_blocking_section(); + if (retcode == 0) { + /* Restore initial mode */ + setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, + (char *) &oldvalue, oldvaluelen); + } + if (snew == INVALID_SOCKET) { + win32_maperr(err); + uerror("accept", Nothing); + } + Begin_roots2 (fd, adr) + fd = win_alloc_socket(snew); + adr = alloc_sockaddr(&addr, addr_len, snew); + res = alloc_small(2, 0); + Field(res, 0) = fd; + Field(res, 1) = adr; + End_roots(); + return res; +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/bind.c b/ocaml-binary-annot/otherlibs/win32unix/bind.c new file mode 100644 index 0000000000..fca9694890 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/bind.c @@ -0,0 +1,34 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <mlvalues.h> +#include "unixsupport.h" +#include "socketaddr.h" + +CAMLprim value unix_bind(socket, address) + value socket, address; +{ + int ret; + union sock_addr_union addr; + socklen_param_type addr_len; + + get_sockaddr(address, &addr, &addr_len); + ret = bind(Socket_val(socket), &addr.s_gen, addr_len); + if (ret == -1) { + win32_maperr(WSAGetLastError()); + uerror("bind", Nothing); + } + return Val_unit; +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/channels.c b/ocaml-binary-annot/otherlibs/win32unix/channels.c new file mode 100644 index 0000000000..1c2cd2734a --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/channels.c @@ -0,0 +1,91 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <mlvalues.h> +#include <alloc.h> +#include <io.h> +#include <memory.h> +#include "unixsupport.h" +#include <fcntl.h> + +extern long _get_osfhandle(int); +extern int _open_osfhandle(long, int); + +int win_CRT_fd_of_filedescr(value handle) +{ + if (CRT_fd_val(handle) != NO_CRT_FD) { + return CRT_fd_val(handle); + } else { + int fd = _open_osfhandle((long) Handle_val(handle), O_BINARY); + if (fd == -1) uerror("channel_of_descr", Nothing); + return fd; + } +} + +CAMLprim value win_inchannel_of_filedescr(value handle) +{ + CAMLparam1(handle); + CAMLlocal1(vchan); + struct channel * chan; + + chan = caml_open_descriptor_in(win_CRT_fd_of_filedescr(handle)); + if (Descr_kind_val(handle) == KIND_SOCKET) + chan->flags |= CHANNEL_FLAG_FROM_SOCKET; + vchan = caml_alloc_channel(chan); + CAMLreturn(vchan); +} + +CAMLprim value win_outchannel_of_filedescr(value handle) +{ + CAMLparam1(handle); + CAMLlocal1(vchan); + int fd; + struct channel * chan; + + chan = caml_open_descriptor_out(win_CRT_fd_of_filedescr(handle)); + if (Descr_kind_val(handle) == KIND_SOCKET) + chan->flags |= CHANNEL_FLAG_FROM_SOCKET; + vchan = caml_alloc_channel(chan); + CAMLreturn(vchan); +} + +CAMLprim value win_filedescr_of_channel(value vchan) +{ + CAMLparam1(vchan); + CAMLlocal1(fd); + struct channel * chan; + HANDLE h; + + chan = Channel(vchan); + if (chan->fd == -1) uerror("descr_of_channel", Nothing); + h = (HANDLE) _get_osfhandle(chan->fd); + if (chan->flags & CHANNEL_FLAG_FROM_SOCKET) + fd = win_alloc_socket((SOCKET) h); + else + fd = win_alloc_handle(h); + CRT_fd_val(fd) = chan->fd; + CAMLreturn(fd); +} + +CAMLprim value win_handle_fd(value vfd) +{ + int crt_fd = Int_val(vfd); + /* PR#4750: do not use the _or_socket variant as it can cause performance + degradation and this function is only used with the standard + handles 0, 1, 2, which are not sockets. */ + value res = win_alloc_handle((HANDLE) _get_osfhandle(crt_fd)); + CRT_fd_val(res) = crt_fd; + return res; +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/close.c b/ocaml-binary-annot/otherlibs/win32unix/close.c new file mode 100644 index 0000000000..48cd60e7aa --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/close.c @@ -0,0 +1,33 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <mlvalues.h> +#include "unixsupport.h" + +CAMLprim value unix_close(value fd) +{ + if (Descr_kind_val(fd) == KIND_SOCKET) { + if (closesocket(Socket_val(fd)) != 0) { + win32_maperr(WSAGetLastError()); + uerror("close", Nothing); + } + } else { + if (! CloseHandle(Handle_val(fd))) { + win32_maperr(GetLastError()); + uerror("close", Nothing); + } + } + return Val_unit; +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/close_on.c b/ocaml-binary-annot/otherlibs/win32unix/close_on.c new file mode 100644 index 0000000000..5b2c4ece32 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/close_on.c @@ -0,0 +1,46 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy and Pascal Cuoq, 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <mlvalues.h> +#include <windows.h> +#include "unixsupport.h" + +int win_set_inherit(value fd, BOOL inherit) +{ + HANDLE oldh, newh; + + oldh = Handle_val(fd); + if (! DuplicateHandle(GetCurrentProcess(), oldh, + GetCurrentProcess(), &newh, + 0L, inherit, DUPLICATE_SAME_ACCESS)) { + win32_maperr(GetLastError()); + return -1; + } + Handle_val(fd) = newh; + CloseHandle(oldh); + return 0; +} + +CAMLprim value win_set_close_on_exec(value fd) +{ + if (win_set_inherit(fd, FALSE) == -1) uerror("set_close_on_exec", Nothing); + return Val_unit; +} + +CAMLprim value win_clear_close_on_exec(value fd) +{ + if (win_set_inherit(fd, TRUE) == -1) uerror("clear_close_on_exec", Nothing); + return Val_unit; +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/connect.c b/ocaml-binary-annot/otherlibs/win32unix/connect.c new file mode 100644 index 0000000000..198d02e2de --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/connect.c @@ -0,0 +1,39 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy and Pascal Cuoq, 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <mlvalues.h> +#include <signals.h> +#include "unixsupport.h" +#include "socketaddr.h" + +CAMLprim value unix_connect(socket, address) + value socket, address; +{ + SOCKET s = Socket_val(socket); + union sock_addr_union addr; + socklen_param_type addr_len; + DWORD err = 0; + + get_sockaddr(address, &addr, &addr_len); + enter_blocking_section(); + if (connect(s, &addr.s_gen, addr_len) == -1) + err = WSAGetLastError(); + leave_blocking_section(); + if (err) { + win32_maperr(err); + uerror("connect", Nothing); + } + return Val_unit; +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/createprocess.c b/ocaml-binary-annot/otherlibs/win32unix/createprocess.c new file mode 100644 index 0000000000..042eaef9e7 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/createprocess.c @@ -0,0 +1,86 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy and Pascal Cuoq, 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <windows.h> +#include <mlvalues.h> +#include <osdeps.h> +#include "unixsupport.h" + +static int win_has_console(void); + +value win_create_process_native(value cmd, value cmdline, value env, + value fd1, value fd2, value fd3) +{ + PROCESS_INFORMATION pi; + STARTUPINFO si; + char * exefile, * envp; + int flags; + + exefile = search_exe_in_path(String_val(cmd)); + if (env != Val_int(0)) { + envp = String_val(Field(env, 0)); + } else { + envp = NULL; + } + /* Prepare stdin/stdout/stderr redirection */ + ZeroMemory(&si, sizeof(STARTUPINFO)); + si.cb = sizeof(STARTUPINFO); + si.dwFlags = STARTF_USESTDHANDLES; + si.hStdInput = Handle_val(fd1); + si.hStdOutput = Handle_val(fd2); + si.hStdError = Handle_val(fd3); + /* If we do not have a console window, then we must create one + before running the process (keep it hidden for apparence). + If we are starting a GUI application, the newly created + console should not matter. */ + if (win_has_console()) + flags = 0; + else { + flags = CREATE_NEW_CONSOLE; + si.dwFlags = (STARTF_USESHOWWINDOW | STARTF_USESTDHANDLES); + si.wShowWindow = SW_HIDE; + } + /* Create the process */ + if (! CreateProcess(exefile, String_val(cmdline), NULL, NULL, + TRUE, flags, envp, NULL, &si, &pi)) { + win32_maperr(GetLastError()); + uerror("create_process", cmd); + } + CloseHandle(pi.hThread); + /* Return the process handle as pseudo-PID + (this is consistent with the wait() emulation in the MSVC C library */ + return Val_long(pi.hProcess); +} + +CAMLprim value win_create_process(value * argv, int argn) +{ + return win_create_process_native(argv[0], argv[1], argv[2], + argv[3], argv[4], argv[5]); +} + +static int win_has_console(void) +{ + HANDLE h, log; + int i; + + h = CreateFile("CONOUT$", GENERIC_WRITE, FILE_SHARE_WRITE, NULL, + OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); + if (h == INVALID_HANDLE_VALUE) { + return 0; + } else { + CloseHandle(h); + return 1; + } +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/dup.c b/ocaml-binary-annot/otherlibs/win32unix/dup.c new file mode 100644 index 0000000000..2668e75bf1 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/dup.c @@ -0,0 +1,33 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <mlvalues.h> +#include "unixsupport.h" + +CAMLprim value unix_dup(value fd) +{ + HANDLE newh; + value newfd; + int kind = Descr_kind_val(fd); + if (! DuplicateHandle(GetCurrentProcess(), Handle_val(fd), + GetCurrentProcess(), &newh, + 0L, TRUE, DUPLICATE_SAME_ACCESS)) { + win32_maperr(GetLastError()); + return -1; + } + newfd = win_alloc_handle(newh); + Descr_kind_val(newfd) = kind; + return newfd; +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/dup2.c b/ocaml-binary-annot/otherlibs/win32unix/dup2.c new file mode 100644 index 0000000000..3f6d37e76d --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/dup2.c @@ -0,0 +1,42 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <mlvalues.h> +#include "unixsupport.h" + +extern int _dup2(int, int); + +CAMLprim value unix_dup2(value fd1, value fd2) +{ + HANDLE oldh, newh; + + oldh = Handle_val(fd2); + if (! DuplicateHandle(GetCurrentProcess(), Handle_val(fd1), + GetCurrentProcess(), &newh, + 0L, TRUE, DUPLICATE_SAME_ACCESS)) { + win32_maperr(GetLastError()); + return -1; + } + Handle_val(fd2) = newh; + if (Descr_kind_val(fd2) == KIND_SOCKET) + closesocket((SOCKET) oldh); + else + CloseHandle(oldh); + Descr_kind_val(fd2) = Descr_kind_val(fd1); + /* Reflect the dup2 on the CRT fds, if any */ + if (CRT_fd_val(fd1) != NO_CRT_FD || CRT_fd_val(fd2) != NO_CRT_FD) + _dup2(win_CRT_fd_of_filedescr(fd1), win_CRT_fd_of_filedescr(fd2)); + return Val_unit; +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/errmsg.c b/ocaml-binary-annot/otherlibs/win32unix/errmsg.c new file mode 100644 index 0000000000..9ce9dddb2a --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/errmsg.c @@ -0,0 +1,43 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2001 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <stdio.h> +#include <errno.h> +#include <string.h> +#include <mlvalues.h> +#include <alloc.h> +#include "unixsupport.h" + +extern int error_table[]; + +CAMLprim value unix_error_message(value err) +{ + int errnum; + char buffer[512]; + + errnum = Is_block(err) ? Int_val(Field(err, 0)) : error_table[Int_val(err)]; + if (errnum > 0) + return copy_string(strerror(errnum)); + if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS, + NULL, + -errnum, + 0, + buffer, + sizeof(buffer), + NULL)) + return copy_string(buffer); + sprintf(buffer, "unknown error #%d", errnum); + return copy_string(buffer); +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/getpeername.c b/ocaml-binary-annot/otherlibs/win32unix/getpeername.c new file mode 100644 index 0000000000..9aeb4c21b0 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/getpeername.c @@ -0,0 +1,35 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy and Pascal Cuoq, 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <mlvalues.h> +#include "unixsupport.h" +#include "socketaddr.h" + +CAMLprim value unix_getpeername(sock) + value sock; +{ + int retcode; + union sock_addr_union addr; + socklen_param_type addr_len; + + addr_len = sizeof(sock_addr); + retcode = getpeername(Socket_val(sock), + &addr.s_gen, &addr_len); + if (retcode == -1) { + win32_maperr(WSAGetLastError()); + uerror("getpeername", Nothing); + } + return alloc_sockaddr(&addr, addr_len, -1); +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/getpid.c b/ocaml-binary-annot/otherlibs/win32unix/getpid.c new file mode 100644 index 0000000000..0892f8f95c --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/getpid.c @@ -0,0 +1,24 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy and Pascal Cuoq, 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <mlvalues.h> +#include "unixsupport.h" + +extern value val_process_id; + +CAMLprim value unix_getpid(value unit) +{ + return val_process_id; +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/getsockname.c b/ocaml-binary-annot/otherlibs/win32unix/getsockname.c new file mode 100644 index 0000000000..88487a43bd --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/getsockname.c @@ -0,0 +1,32 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy and Pascal Cuoq, 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <mlvalues.h> +#include "unixsupport.h" +#include "socketaddr.h" + +CAMLprim value unix_getsockname(sock) + value sock; +{ + int retcode; + union sock_addr_union addr; + socklen_param_type addr_len; + + addr_len = sizeof(sock_addr); + retcode = getsockname(Socket_val(sock), + &addr.s_gen, &addr_len); + if (retcode == -1) uerror("getsockname", Nothing); + return alloc_sockaddr(&addr, addr_len, -1); +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/gettimeofday.c b/ocaml-binary-annot/otherlibs/win32unix/gettimeofday.c new file mode 100644 index 0000000000..f1313f0617 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/gettimeofday.c @@ -0,0 +1,36 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <mlvalues.h> +#include <alloc.h> +#include <time.h> + +#include "unixsupport.h" + +static time_t initial_time = 0; /* 0 means uninitialized */ +static DWORD initial_tickcount; + +CAMLprim value unix_gettimeofday(value unit) +{ + DWORD tickcount = GetTickCount(); + if (initial_time == 0 || tickcount < initial_tickcount) { + initial_tickcount = tickcount; + initial_time = time(NULL); + return copy_double((double) initial_time); + } else { + return copy_double((double) initial_time + + (double) (tickcount - initial_tickcount) * 1e-3); + } +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/libunix.clib b/ocaml-binary-annot/otherlibs/win32unix/libunix.clib new file mode 100644 index 0000000000..043dcf7600 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/libunix.clib @@ -0,0 +1,17 @@ +# Files in this directory +accept.o bind.o channels.o close.o +close_on.o connect.o createprocess.o dup.o dup2.o errmsg.o +getpeername.o getpid.o getsockname.o gettimeofday.o +link.o listen.o lockf.o lseek.o nonblock.o +mkdir.o open.o pipe.o read.o rename.o +select.o sendrecv.o +shutdown.o sleep.o socket.o sockopt.o startup.o stat.o +system.o unixsupport.o windir.o winwait.o write.o +winlist.o winworker.o windbug.o + +# Files from the ../unix directory +access.o addrofstr.o chdir.o chmod.o cst2constr.o +cstringv.o envir.o execv.o execve.o execvp.o +exit.o getcwd.o gethost.o gethostname.o getproto.o +getserv.o gmtime.o putenv.o rmdir.o +socketaddr.o strofaddr.o time.o unlink.o utimes.o diff --git a/ocaml-binary-annot/otherlibs/win32unix/link.c b/ocaml-binary-annot/otherlibs/win32unix/link.c new file mode 100644 index 0000000000..8921434234 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/link.c @@ -0,0 +1,42 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* File contributed by Lionel Fourquaux */ +/* */ +/* Copyright 2001 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <windows.h> +#include <mlvalues.h> +#include <fail.h> +#include "unixsupport.h" + +typedef +BOOL (WINAPI *tCreateHardLink)( + LPCTSTR lpFileName, + LPCTSTR lpExistingFileName, + LPSECURITY_ATTRIBUTES lpSecurityAttributes +); + +CAMLprim value unix_link(value path1, value path2) +{ + HMODULE hModKernel32; + tCreateHardLink pCreateHardLink; + hModKernel32 = GetModuleHandle("KERNEL32.DLL"); + pCreateHardLink = + (tCreateHardLink) GetProcAddress(hModKernel32, "CreateHardLinkA"); + if (pCreateHardLink == NULL) + invalid_argument("Unix.link not implemented"); + if (! pCreateHardLink(String_val(path2), String_val(path1), NULL)) { + win32_maperr(GetLastError()); + uerror("link", path2); + } + return Val_unit; +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/listen.c b/ocaml-binary-annot/otherlibs/win32unix/listen.c new file mode 100644 index 0000000000..20789e1a4c --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/listen.c @@ -0,0 +1,27 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy and Pascal Cuoq, 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <mlvalues.h> +#include "unixsupport.h" + +CAMLprim value unix_listen(sock, backlog) + value sock, backlog; +{ + if (listen(Socket_val(sock), Int_val(backlog)) == -1) { + win32_maperr(WSAGetLastError()); + uerror("listen", Nothing); + } + return Val_unit; +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/lockf.c b/ocaml-binary-annot/otherlibs/win32unix/lockf.c new file mode 100644 index 0000000000..524f9516b6 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/lockf.c @@ -0,0 +1,160 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Contributed by Tracy Camp, PolyServe Inc., <campt@polyserve.com> */ +/* Further improvements by Reed Wilson */ +/* */ +/* Copyright 2002 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. */ +/* under the terms of the GNU Library General Public License. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <errno.h> +#include <fcntl.h> +#include <mlvalues.h> +#include <memory.h> +#include <fail.h> +#include "unixsupport.h" +#include <stdio.h> +#include <signals.h> + +#ifndef INVALID_SET_FILE_POINTER +#define INVALID_SET_FILE_POINTER (-1) +#endif + +/* Sets handle h to a position based on gohere */ +/* output, if set, is changed to the new location */ + +static void set_file_pointer(HANDLE h, LARGE_INTEGER gohere, + PLARGE_INTEGER output, DWORD method) +{ + LONG high = gohere.HighPart; + DWORD ret = SetFilePointer(h, gohere.LowPart, &high, method); + if(ret == INVALID_SET_FILE_POINTER) { + DWORD err = GetLastError(); + if(err != NO_ERROR) { + win32_maperr(err); + uerror("lockf", Nothing); + } + } + if(output != NULL) { + output->LowPart = ret; + output->HighPart = high; + } +} + +CAMLprim value unix_lockf(value fd, value cmd, value span) +{ + CAMLparam3(fd, cmd, span); + OVERLAPPED overlap; + intnat l_len; + HANDLE h; + OSVERSIONINFO version; + LARGE_INTEGER cur_position; + LARGE_INTEGER beg_position; + LARGE_INTEGER lock_len; + LARGE_INTEGER zero; + DWORD err = NO_ERROR; + + version.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); + if(GetVersionEx(&version) == 0) { + invalid_argument("lockf only supported on WIN32_NT platforms: could not determine current platform."); + } + if(version.dwPlatformId != VER_PLATFORM_WIN32_NT) { + invalid_argument("lockf only supported on WIN32_NT platforms"); + } + + h = Handle_val(fd); + + l_len = Long_val(span); + + /* No matter what, we need the current position in the file */ + zero.HighPart = zero.LowPart = 0; + set_file_pointer(h, zero, &cur_position, FILE_CURRENT); + + /* All unused fields must be set to zero */ + memset(&overlap, 0, sizeof(overlap)); + + if(l_len == 0) { + /* Lock from cur to infinity */ + lock_len.QuadPart = -1; + overlap.OffsetHigh = cur_position.HighPart; + overlap.Offset = cur_position.LowPart ; + } + else if(l_len > 0) { + /* Positive file offset */ + lock_len.QuadPart = l_len; + overlap.OffsetHigh = cur_position.HighPart; + overlap.Offset = cur_position.LowPart ; + } + else { + /* Negative file offset */ + lock_len.QuadPart = - l_len; + if (lock_len.QuadPart > cur_position.QuadPart) { + errno = EINVAL; + uerror("lockf", Nothing); + } + beg_position.QuadPart = cur_position.QuadPart - lock_len.QuadPart; + overlap.OffsetHigh = beg_position.HighPart; + overlap.Offset = beg_position.LowPart ; + } + + switch(Int_val(cmd)) { + case 0: /* F_ULOCK - unlock */ + if (! UnlockFileEx(h, 0, + lock_len.LowPart, lock_len.HighPart, &overlap)) + err = GetLastError(); + break; + case 1: /* F_LOCK - blocking write lock */ + enter_blocking_section(); + if (! LockFileEx(h, LOCKFILE_EXCLUSIVE_LOCK, 0, + lock_len.LowPart, lock_len.HighPart, &overlap)) + err = GetLastError(); + leave_blocking_section(); + break; + case 2: /* F_TLOCK - non-blocking write lock */ + if (! LockFileEx(h, LOCKFILE_FAIL_IMMEDIATELY | LOCKFILE_EXCLUSIVE_LOCK, 0, + lock_len.LowPart, lock_len.HighPart, &overlap)) + err = GetLastError(); + break; + case 3: /* F_TEST - check whether a write lock can be obtained */ + /* I'm doing this by aquiring an immediate write + * lock and then releasing it. It is not clear that + * this behavior matches anything in particular, but + * it is not clear the nature of the lock test performed + * by ocaml (unix) currently. */ + if (LockFileEx(h, LOCKFILE_FAIL_IMMEDIATELY | LOCKFILE_EXCLUSIVE_LOCK, 0, + lock_len.LowPart, lock_len.HighPart, &overlap)) { + UnlockFileEx(h, 0, lock_len.LowPart, lock_len.HighPart, &overlap); + } else { + err = GetLastError(); + } + break; + case 4: /* F_RLOCK - blocking read lock */ + enter_blocking_section(); + if (! LockFileEx(h, 0, 0, + lock_len.LowPart, lock_len.HighPart, &overlap)) + err = GetLastError(); + leave_blocking_section(); + break; + case 5: /* F_TRLOCK - non-blocking read lock */ + if (! LockFileEx(h, LOCKFILE_FAIL_IMMEDIATELY, 0, + lock_len.LowPart, lock_len.HighPart, &overlap)) + err = GetLastError(); + break; + default: + errno = EINVAL; + uerror("lockf", Nothing); + } + if (err != NO_ERROR) { + win32_maperr(err); + uerror("lockf", Nothing); + } + CAMLreturn(Val_unit); +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/lseek.c b/ocaml-binary-annot/otherlibs/win32unix/lseek.c new file mode 100644 index 0000000000..9619fcc92a --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/lseek.c @@ -0,0 +1,70 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <mlvalues.h> +#include <alloc.h> +#include "unixsupport.h" + +#ifdef HAS_UNISTD +#include <unistd.h> +#else +#define SEEK_SET 0 +#define SEEK_CUR 1 +#define SEEK_END 2 +#endif + +static DWORD seek_command_table[] = { + FILE_BEGIN, FILE_CURRENT, FILE_END +}; + +#ifndef INVALID_SET_FILE_POINTER +#define INVALID_SET_FILE_POINTER (-1) +#endif + +static __int64 caml_set_file_pointer(HANDLE h, __int64 dist, DWORD mode) +{ + LARGE_INTEGER i; + DWORD err; + + i.QuadPart = dist; + i.LowPart = SetFilePointer(h, i.LowPart, &i.HighPart, mode); + if (i.LowPart == INVALID_SET_FILE_POINTER) { + err = GetLastError(); + if (err != NO_ERROR) { win32_maperr(err); uerror("lseek", Nothing); } + } + return i.QuadPart; +} + +CAMLprim value unix_lseek(value fd, value ofs, value cmd) +{ + __int64 ret; + + ret = caml_set_file_pointer(Handle_val(fd), Long_val(ofs), + seek_command_table[Int_val(cmd)]); + if (ret > Max_long) { + win32_maperr(ERROR_ARITHMETIC_OVERFLOW); + uerror("lseek", Nothing); + } + return Val_long(ret); +} + +CAMLprim value unix_lseek_64(value fd, value ofs, value cmd) +{ + __int64 ret; + + ret = caml_set_file_pointer(Handle_val(fd), Int64_val(ofs), + seek_command_table[Int_val(cmd)]); + return copy_int64(ret); +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/mkdir.c b/ocaml-binary-annot/otherlibs/win32unix/mkdir.c new file mode 100644 index 0000000000..aae54783bc --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/mkdir.c @@ -0,0 +1,24 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy and Pascal Cuoq, 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <mlvalues.h> +#include "unixsupport.h" + +CAMLprim value unix_mkdir(path, perm) + value path, perm; +{ + if (_mkdir(String_val(path)) == -1) uerror("mkdir", path); + return Val_unit; +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/nonblock.c b/ocaml-binary-annot/otherlibs/win32unix/nonblock.c new file mode 100755 index 0000000000..1bf80bfc7e --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/nonblock.c @@ -0,0 +1,44 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2002 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <mlvalues.h> +#include <signals.h> +#include "unixsupport.h" + +CAMLprim value unix_set_nonblock(socket) + value socket; +{ + u_long non_block = 1; + + if (ioctlsocket(Socket_val(socket), FIONBIO, &non_block) != 0) { + win32_maperr(WSAGetLastError()); + uerror("unix_set_nonblock", Nothing); + } + Flags_fd_val(socket) = Flags_fd_val(socket) | FLAGS_FD_IS_BLOCKING; + return Val_unit; +} + +CAMLprim value unix_clear_nonblock(socket) + value socket; +{ + u_long non_block = 0; + + if (ioctlsocket(Socket_val(socket), FIONBIO, &non_block) != 0) { + win32_maperr(WSAGetLastError()); + uerror("unix_clear_nonblock", Nothing); + } + Flags_fd_val(socket) = Flags_fd_val(socket) & ~FLAGS_FD_IS_BLOCKING; + return Val_unit; +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/open.c b/ocaml-binary-annot/otherlibs/win32unix/open.c new file mode 100644 index 0000000000..f2f334bbb4 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/open.c @@ -0,0 +1,67 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy and Pascal Cuoq, 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <mlvalues.h> +#include <alloc.h> +#include "unixsupport.h" +#include <fcntl.h> + +static int open_access_flags[12] = { + GENERIC_READ, GENERIC_WRITE, GENERIC_READ|GENERIC_WRITE, + 0, 0, 0, 0, 0, 0, 0, 0, 0 +}; + +static int open_create_flags[12] = { + 0, 0, 0, 0, 0, O_CREAT, O_TRUNC, O_EXCL, 0, 0, 0, 0 +}; + +CAMLprim value unix_open(value path, value flags, value perm) +{ + int fileaccess, createflags, fileattrib, filecreate; + SECURITY_ATTRIBUTES attr; + HANDLE h; + + fileaccess = convert_flag_list(flags, open_access_flags); + + createflags = convert_flag_list(flags, open_create_flags); + if ((createflags & (O_CREAT | O_EXCL)) == (O_CREAT | O_EXCL)) + filecreate = CREATE_NEW; + else if ((createflags & (O_CREAT | O_TRUNC)) == (O_CREAT | O_TRUNC)) + filecreate = CREATE_ALWAYS; + else if (createflags & O_TRUNC) + filecreate = TRUNCATE_EXISTING; + else if (createflags & O_CREAT) + filecreate = OPEN_ALWAYS; + else + filecreate = OPEN_EXISTING; + + if ((createflags & O_CREAT) && (Int_val(perm) & 0200) == 0) + fileattrib = FILE_ATTRIBUTE_READONLY; + else + fileattrib = FILE_ATTRIBUTE_NORMAL; + + attr.nLength = sizeof(attr); + attr.lpSecurityDescriptor = NULL; + attr.bInheritHandle = TRUE; + + h = CreateFile(String_val(path), fileaccess, + FILE_SHARE_READ | FILE_SHARE_WRITE, &attr, + filecreate, fileattrib, NULL); + if (h == INVALID_HANDLE_VALUE) { + win32_maperr(GetLastError()); + uerror("open", path); + } + return win_alloc_handle(h); +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/pipe.c b/ocaml-binary-annot/otherlibs/win32unix/pipe.c new file mode 100644 index 0000000000..afacd3e17e --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/pipe.c @@ -0,0 +1,46 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy and Pascal Cuoq, 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <mlvalues.h> +#include <memory.h> +#include <alloc.h> +#include "unixsupport.h" +#include <fcntl.h> + +/* PR#4749: pick a size that matches that of I/O buffers */ +#define SIZEBUF 4096 + +CAMLprim value unix_pipe(value unit) +{ + SECURITY_ATTRIBUTES attr; + HANDLE readh, writeh; + value readfd = Val_unit, writefd = Val_unit, res; + + attr.nLength = sizeof(attr); + attr.lpSecurityDescriptor = NULL; + attr.bInheritHandle = TRUE; + if (! CreatePipe(&readh, &writeh, &attr, SIZEBUF)) { + win32_maperr(GetLastError()); + uerror("pipe", Nothing); + } + Begin_roots2(readfd, writefd) + readfd = win_alloc_handle(readh); + writefd = win_alloc_handle(writeh); + res = alloc_small(2, 0); + Field(res, 0) = readfd; + Field(res, 1) = writefd; + End_roots(); + return res; +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/read.c b/ocaml-binary-annot/otherlibs/win32unix/read.c new file mode 100644 index 0000000000..67882eb77a --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/read.c @@ -0,0 +1,54 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <string.h> +#include <mlvalues.h> +#include <memory.h> +#include <signals.h> +#include "unixsupport.h" + +CAMLprim value unix_read(value fd, value buf, value ofs, value vlen) +{ + intnat len; + DWORD numbytes, numread; + char iobuf[UNIX_BUFFER_SIZE]; + DWORD err = 0; + + Begin_root (buf); + len = Long_val(vlen); + numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len; + if (Descr_kind_val(fd) == KIND_SOCKET) { + int ret; + SOCKET s = Socket_val(fd); + enter_blocking_section(); + ret = recv(s, iobuf, numbytes, 0); + if (ret == SOCKET_ERROR) err = WSAGetLastError(); + leave_blocking_section(); + numread = ret; + } else { + HANDLE h = Handle_val(fd); + enter_blocking_section(); + if (! ReadFile(h, iobuf, numbytes, &numread, NULL)) + err = GetLastError(); + leave_blocking_section(); + } + if (err) { + win32_maperr(err); + uerror("read", Nothing); + } + memmove (&Byte(buf, Long_val(ofs)), iobuf, numread); + End_roots(); + return Val_int(numread); +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/rename.c b/ocaml-binary-annot/otherlibs/win32unix/rename.c new file mode 100644 index 0000000000..9ab43fca89 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/rename.c @@ -0,0 +1,43 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Contributed by Tracy Camp, PolyServe Inc., <campt@polyserve.com> */ +/* */ +/* Copyright 2002 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <stdio.h> +#include <mlvalues.h> +#include "unixsupport.h" + +CAMLprim value unix_rename(value path1, value path2) +{ + static int supports_MoveFileEx = -1; /* don't know yet */ + BOOL ok; + + if (supports_MoveFileEx < 0) { + OSVERSIONINFO VersionInfo; + VersionInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); + supports_MoveFileEx = + (GetVersionEx(&VersionInfo) != 0) + && (VersionInfo.dwPlatformId == VER_PLATFORM_WIN32_NT); + } + if (supports_MoveFileEx > 0) + ok = MoveFileEx(String_val(path1), String_val(path2), + MOVEFILE_REPLACE_EXISTING | MOVEFILE_WRITE_THROUGH | + MOVEFILE_COPY_ALLOWED); + else + ok = MoveFile(String_val(path1), String_val(path2)); + if (! ok) { + win32_maperr(GetLastError()); + uerror("rename", path1); + } + return Val_unit; +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/select.c b/ocaml-binary-annot/otherlibs/win32unix/select.c new file mode 100644 index 0000000000..b82c423cc5 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/select.c @@ -0,0 +1,1112 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Contributed by Sylvain Le Gall for Lexifi */ +/* */ +/* Copyright 2008 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <mlvalues.h> +#include <alloc.h> +#include <memory.h> +#include <fail.h> +#include <signals.h> +#include <winsock2.h> +#include <windows.h> +#include <stdio.h> +#include "unixsupport.h" +#include "windbug.h" +#include "winworker.h" +#include "winlist.h" + +/* This constant define the maximum number of objects that + * can be handle by a SELECTDATA. + * It takes the following parameters into account: + * - limitation on number of objects is mostly due to limitation + * a WaitForMultipleObjects + * - there is always an event "hStop" to watch + * + * This lead to pick the following value as the biggest possible + * value + */ +#define MAXIMUM_SELECT_OBJECTS (MAXIMUM_WAIT_OBJECTS - 1) + +/* Manage set of handle */ +typedef struct _SELECTHANDLESET { + LPHANDLE lpHdl; + DWORD nMax; + DWORD nLast; +} SELECTHANDLESET; + +typedef SELECTHANDLESET *LPSELECTHANDLESET; + +void handle_set_init (LPSELECTHANDLESET hds, LPHANDLE lpHdl, DWORD max) +{ + DWORD i; + + hds->lpHdl = lpHdl; + hds->nMax = max; + hds->nLast = 0; + + /* Set to invalid value every entry of the handle */ + for (i = 0; i < hds->nMax; i++) + { + hds->lpHdl[i] = INVALID_HANDLE_VALUE; + }; +} + +void handle_set_add (LPSELECTHANDLESET hds, HANDLE hdl) +{ + LPSELECTHANDLESET res; + + if (hds->nLast < hds->nMax) + { + hds->lpHdl[hds->nLast] = hdl; + hds->nLast++; + } + + DEBUG_PRINT("Adding handle %x to set %x", hdl, hds); +} + +BOOL handle_set_mem (LPSELECTHANDLESET hds, HANDLE hdl) +{ + BOOL res; + DWORD i; + + res = FALSE; + for (i = 0; !res && i < hds->nLast; i++) + { + res = (hds->lpHdl[i] == hdl); + } + + return res; +} + +void handle_set_reset (LPSELECTHANDLESET hds) +{ + DWORD i; + + for (i = 0; i < hds->nMax; i++) + { + hds->lpHdl[i] = INVALID_HANDLE_VALUE; + } + hds->nMax = 0; + hds->nLast = 0; + hds->lpHdl = NULL; +} + +/* Data structure for handling select */ + +typedef enum _SELECTHANDLETYPE { + SELECT_HANDLE_NONE = 0, + SELECT_HANDLE_DISK, + SELECT_HANDLE_CONSOLE, + SELECT_HANDLE_PIPE, + SELECT_HANDLE_SOCKET, +} SELECTHANDLETYPE; + +typedef enum _SELECTMODE { + SELECT_MODE_NONE = 0, + SELECT_MODE_READ, + SELECT_MODE_WRITE, + SELECT_MODE_EXCEPT, +} SELECTMODE; + +typedef enum _SELECTSTATE { + SELECT_STATE_NONE = 0, + SELECT_STATE_INITFAILED, + SELECT_STATE_ERROR, + SELECT_STATE_SIGNALED +} SELECTSTATE; + +typedef enum _SELECTTYPE { + SELECT_TYPE_NONE = 0, + SELECT_TYPE_STATIC, /* Result is known without running anything */ + SELECT_TYPE_CONSOLE_READ, /* Reading data on console */ + SELECT_TYPE_PIPE_READ, /* Reading data on pipe */ + SELECT_TYPE_SOCKET /* Classic select */ +} SELECTTYPE; + +/* Data structure for results */ +typedef struct _SELECTRESULT { + LIST lst; + SELECTMODE EMode; + int lpOrigIdx; +} SELECTRESULT; + +typedef SELECTRESULT *LPSELECTRESULT; + +/* Data structure for query */ +typedef struct _SELECTQUERY { + LIST lst; + SELECTMODE EMode; + HANDLE hFileDescr; + int lpOrigIdx; + unsigned int uFlagsFd; /* Copy of filedescr->flags_fd */ +} SELECTQUERY; + +typedef SELECTQUERY *LPSELECTQUERY; + +typedef struct _SELECTDATA { + LIST lst; + SELECTTYPE EType; + SELECTRESULT aResults[MAXIMUM_SELECT_OBJECTS]; + DWORD nResultsCount; + /* Data following are dedicated to APC like call, they + will be initialized if required. + */ + WORKERFUNC funcWorker; + SELECTQUERY aQueries[MAXIMUM_SELECT_OBJECTS]; + DWORD nQueriesCount; + SELECTSTATE EState; + DWORD nError; + LPWORKER lpWorker; +} SELECTDATA; + +typedef SELECTDATA *LPSELECTDATA; + +/* Get error status if associated condition is false */ +static BOOL check_error(LPSELECTDATA lpSelectData, BOOL bFailed) +{ + if (bFailed && lpSelectData->nError == 0) + { + lpSelectData->EState = SELECT_STATE_ERROR; + lpSelectData->nError = GetLastError(); + } + return bFailed; +} + +/* Create data associated with a select operation */ +LPSELECTDATA select_data_new (LPSELECTDATA lpSelectData, SELECTTYPE EType) +{ + /* Allocate the data structure */ + LPSELECTDATA res; + DWORD i; + + res = (LPSELECTDATA)caml_stat_alloc(sizeof(SELECTDATA)); + + /* Init common data */ + list_init((LPLIST)res); + list_next_set((LPLIST)res, (LPLIST)lpSelectData); + res->EType = EType; + res->nResultsCount = 0; + + + /* Data following are dedicated to APC like call, they + will be initialized if required. For now they are set to + invalid values. + */ + res->funcWorker = NULL; + res->nQueriesCount = 0; + res->EState = SELECT_STATE_NONE; + res->nError = 0; + res->lpWorker = NULL; + + return res; +} + +/* Free select data */ +void select_data_free (LPSELECTDATA lpSelectData) +{ + DWORD i; + + DEBUG_PRINT("Freeing data of %x", lpSelectData); + + /* Free APC related data, if they exists */ + if (lpSelectData->lpWorker != NULL) + { + worker_job_finish(lpSelectData->lpWorker); + lpSelectData->lpWorker = NULL; + }; + + /* Make sure results/queries cannot be accessed */ + lpSelectData->nResultsCount = 0; + lpSelectData->nQueriesCount = 0; + + caml_stat_free(lpSelectData); +} + +/* Add a result to select data, return zero if something goes wrong. */ +DWORD select_data_result_add (LPSELECTDATA lpSelectData, SELECTMODE EMode, int lpOrigIdx) +{ + DWORD res; + DWORD i; + + res = 0; + if (lpSelectData->nResultsCount < MAXIMUM_SELECT_OBJECTS) + { + i = lpSelectData->nResultsCount; + lpSelectData->aResults[i].EMode = EMode; + lpSelectData->aResults[i].lpOrigIdx = lpOrigIdx; + lpSelectData->nResultsCount++; + res = 1; + } + + return res; +} + +/* Add a query to select data, return zero if something goes wrong */ +DWORD select_data_query_add (LPSELECTDATA lpSelectData, + SELECTMODE EMode, + HANDLE hFileDescr, + int lpOrigIdx, + unsigned int uFlagsFd) +{ + DWORD res; + DWORD i; + + res = 0; + if (lpSelectData->nQueriesCount < MAXIMUM_SELECT_OBJECTS) + { + i = lpSelectData->nQueriesCount; + lpSelectData->aQueries[i].EMode = EMode; + lpSelectData->aQueries[i].hFileDescr = hFileDescr; + lpSelectData->aQueries[i].lpOrigIdx = lpOrigIdx; + lpSelectData->aQueries[i].uFlagsFd = uFlagsFd; + lpSelectData->nQueriesCount++; + res = 1; + } + + return res; +} + +/* Search for a job that has available query slots and that match provided type. + * If none is found, create a new one. Return the corresponding SELECTDATA, and + * update provided SELECTDATA head, if required. + */ +LPSELECTDATA select_data_job_search (LPSELECTDATA *lppSelectData, SELECTTYPE EType) +{ + LPSELECTDATA res; + + res = NULL; + + /* Search for job */ + DEBUG_PRINT("Searching an available job for type %d", EType); + res = *lppSelectData; + while ( + res != NULL + && !( + res->EType == EType + && res->nQueriesCount < MAXIMUM_SELECT_OBJECTS + ) + ) + { + res = LIST_NEXT(LPSELECTDATA, res); + } + + /* No matching job found, create one */ + if (res == NULL) + { + DEBUG_PRINT("No job for type %d found, create one", EType); + res = select_data_new(*lppSelectData, EType); + *lppSelectData = res; + } + + return res; +} + +/***********************/ +/* Console */ +/***********************/ + +void read_console_poll(HANDLE hStop, void *_data) +{ + HANDLE events[2]; + INPUT_RECORD record; + DWORD waitRes; + DWORD n; + LPSELECTDATA lpSelectData; + LPSELECTQUERY lpQuery; + + DEBUG_PRINT("Waiting for data on console"); + + record; + waitRes = 0; + n = 0; + lpSelectData = (LPSELECTDATA)_data; + lpQuery = &(lpSelectData->aQueries[0]); + + events[0] = hStop; + events[1] = lpQuery->hFileDescr; + while (lpSelectData->EState == SELECT_STATE_NONE) + { + waitRes = WaitForMultipleObjects(2, events, FALSE, INFINITE); + if (waitRes == WAIT_OBJECT_0 || check_error(lpSelectData, waitRes == WAIT_FAILED)) + { + /* stop worker event or error */ + break; + } + /* console event */ + if (check_error(lpSelectData, PeekConsoleInput(lpQuery->hFileDescr, &record, 1, &n) == 0)) + { + break; + } + /* check for ASCII keypress only */ + if (record.EventType == KEY_EVENT && + record.Event.KeyEvent.bKeyDown && + record.Event.KeyEvent.uChar.AsciiChar != 0) + { + select_data_result_add(lpSelectData, lpQuery->EMode, lpQuery->lpOrigIdx); + lpSelectData->EState = SELECT_STATE_SIGNALED; + break; + } + else + { + /* discard everything else and try again */ + if (check_error(lpSelectData, ReadConsoleInput(lpQuery->hFileDescr, &record, 1, &n) == 0)) + { + break; + } + } + }; +} + +/* Add a function to monitor console input */ +LPSELECTDATA read_console_poll_add (LPSELECTDATA lpSelectData, + SELECTMODE EMode, + HANDLE hFileDescr, + int lpOrigIdx, + unsigned int uFlagsFd) +{ + LPSELECTDATA res; + + res = select_data_new(lpSelectData, SELECT_TYPE_CONSOLE_READ); + res->funcWorker = read_console_poll; + select_data_query_add(res, SELECT_MODE_READ, hFileDescr, lpOrigIdx, uFlagsFd); + + return res; +} + +/***********************/ +/* Pipe */ +/***********************/ + +/* Monitor a pipe for input */ +void read_pipe_poll (HANDLE hStop, void *_data) +{ + DWORD res; + DWORD event; + DWORD n; + LPSELECTQUERY iterQuery; + LPSELECTDATA lpSelectData; + DWORD i; + DWORD wait; + + /* Poll pipe */ + event = 0; + n = 0; + lpSelectData = (LPSELECTDATA)_data; + wait = 1; + + DEBUG_PRINT("Checking data pipe"); + while (lpSelectData->EState == SELECT_STATE_NONE) + { + for (i = 0; i < lpSelectData->nQueriesCount; i++) + { + iterQuery = &(lpSelectData->aQueries[i]); + res = PeekNamedPipe( + iterQuery->hFileDescr, + NULL, + 0, + NULL, + &n, + NULL); + if (check_error(lpSelectData, + (res == 0) && + (GetLastError() != ERROR_BROKEN_PIPE))) + { + break; + }; + + if ((n > 0) || (res == 0)) + { + lpSelectData->EState = SELECT_STATE_SIGNALED; + select_data_result_add(lpSelectData, iterQuery->EMode, iterQuery->lpOrigIdx); + }; + }; + + /* Alas, nothing except polling seems to work for pipes. + Check the state & stop_worker_event every 10 ms + */ + if (lpSelectData->EState == SELECT_STATE_NONE) + { + event = WaitForSingleObject(hStop, wait); + + /* Fast start: begin to wait 1, 2, 4, 8 and then 10 ms. + * If we are working with the output of a program there is + * a chance that one of the 4 first calls succeed. + */ + wait = 2 * wait; + if (wait > 10) + { + wait = 10; + }; + if (event == WAIT_OBJECT_0 || check_error(lpSelectData, event == WAIT_FAILED)) + { + break; + } + } + } + DEBUG_PRINT("Finish checking data on pipe"); +} + +/* Add a function to monitor pipe input */ +LPSELECTDATA read_pipe_poll_add (LPSELECTDATA lpSelectData, + SELECTMODE EMode, + HANDLE hFileDescr, + int lpOrigIdx, + unsigned int uFlagsFd) +{ + LPSELECTDATA res; + LPSELECTDATA hd; + + hd = lpSelectData; + /* Polling pipe is a non blocking operation by default. This means that each + worker can handle many pipe. We begin to try to find a worker that is + polling pipe, but for which there is under the limit of pipe per worker. + */ + DEBUG_PRINT("Searching an available worker handling pipe"); + res = select_data_job_search(&hd, SELECT_TYPE_PIPE_READ); + + /* Add a new pipe to poll */ + res->funcWorker = read_pipe_poll; + select_data_query_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd); + + return hd; +} + +/***********************/ +/* Socket */ +/***********************/ + +/* Monitor socket */ +void socket_poll (HANDLE hStop, void *_data) +{ + LPSELECTDATA lpSelectData; + LPSELECTQUERY iterQuery; + HANDLE aEvents[MAXIMUM_SELECT_OBJECTS]; + DWORD nEvents; + long maskEvents; + DWORD i; + u_long iMode; + + lpSelectData = (LPSELECTDATA)_data; + + for (nEvents = 0; nEvents < lpSelectData->nQueriesCount; nEvents++) + { + iterQuery = &(lpSelectData->aQueries[nEvents]); + aEvents[nEvents] = CreateEvent(NULL, TRUE, FALSE, NULL); + maskEvents = 0; + switch (iterQuery->EMode) + { + case SELECT_MODE_READ: + maskEvents = FD_READ | FD_ACCEPT | FD_CLOSE; + break; + case SELECT_MODE_WRITE: + maskEvents = FD_WRITE | FD_CONNECT | FD_CLOSE; + break; + case SELECT_MODE_EXCEPT: + maskEvents = FD_OOB; + break; + } + + check_error(lpSelectData, + WSAEventSelect( + (SOCKET)(iterQuery->hFileDescr), + aEvents[nEvents], + maskEvents) == SOCKET_ERROR); + } + + /* Add stop event */ + aEvents[nEvents] = hStop; + nEvents++; + + if (lpSelectData->nError == 0) + { + check_error(lpSelectData, + WaitForMultipleObjects( + nEvents, + aEvents, + FALSE, + INFINITE) == WAIT_FAILED); + }; + + if (lpSelectData->nError == 0) + { + for (i = 0; i < lpSelectData->nQueriesCount; i++) + { + iterQuery = &(lpSelectData->aQueries[i]); + if (WaitForSingleObject(aEvents[i], 0) == WAIT_OBJECT_0) + { + DEBUG_PRINT("Socket %d has pending events", (i - 1)); + if (iterQuery != NULL) + { + select_data_result_add(lpSelectData, iterQuery->EMode, iterQuery->lpOrigIdx); + } + } + /* WSAEventSelect() automatically sets socket to nonblocking mode. + Restore the blocking one. */ + if (iterQuery->uFlagsFd & FLAGS_FD_IS_BLOCKING) + { + DEBUG_PRINT("Restore a blocking socket"); + iMode = 1; + check_error(lpSelectData, + WSAEventSelect((SOCKET)(iterQuery->hFileDescr), aEvents[i], 0) != 0 || + ioctlsocket((SOCKET)(iterQuery->hFileDescr), FIONBIO, &iMode) != 0); + } + else + { + check_error(lpSelectData, + WSAEventSelect((SOCKET)(iterQuery->hFileDescr), aEvents[i], 0) != 0); + }; + + CloseHandle(aEvents[i]); + aEvents[i] = INVALID_HANDLE_VALUE; + } + } +} + +/* Add a function to monitor socket */ +LPSELECTDATA socket_poll_add (LPSELECTDATA lpSelectData, + SELECTMODE EMode, + HANDLE hFileDescr, + int lpOrigIdx, + unsigned int uFlagsFd) +{ + LPSELECTDATA res; + LPSELECTDATA hd; + + hd = lpSelectData; + /* Polling socket can be done mulitple handle at the same time. You just + need one worker to use it. Try to find if there is already a worker + handling this kind of request. + */ + DEBUG_PRINT("Scanning list of worker to find one that already handle socket"); + res = select_data_job_search(&hd, SELECT_TYPE_SOCKET); + + /* Add a new socket to poll */ + res->funcWorker = socket_poll; + DEBUG_PRINT("Add socket %x to worker", hFileDescr); + select_data_query_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd); + DEBUG_PRINT("Socket %x added", hFileDescr); + + return hd; +} + +/***********************/ +/* Static */ +/***********************/ + +/* Add a static result */ +LPSELECTDATA static_poll_add (LPSELECTDATA lpSelectData, + SELECTMODE EMode, + HANDLE hFileDescr, + int lpOrigIdx, + unsigned int uFlagsFd) +{ + LPSELECTDATA res; + LPSELECTDATA hd; + + /* Look for an already initialized static element */ + hd = lpSelectData; + res = select_data_job_search(&hd, SELECT_TYPE_STATIC); + + /* Add a new query/result */ + select_data_query_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd); + select_data_result_add(res, EMode, lpOrigIdx); + + return hd; +} + +/********************************/ +/* Generic select data handling */ +/********************************/ + +/* Guess handle type */ +static SELECTHANDLETYPE get_handle_type(value fd) +{ + DWORD mode; + SELECTHANDLETYPE res; + + CAMLparam1(fd); + + mode = 0; + res = SELECT_HANDLE_NONE; + + if (Descr_kind_val(fd) == KIND_SOCKET) + { + res = SELECT_HANDLE_SOCKET; + } + else + { + switch(GetFileType(Handle_val(fd))) + { + case FILE_TYPE_DISK: + res = SELECT_HANDLE_DISK; + break; + + case FILE_TYPE_CHAR: /* character file or a console */ + if (GetConsoleMode(Handle_val(fd), &mode) != 0) + { + res = SELECT_HANDLE_CONSOLE; + } + else + { + res = SELECT_HANDLE_NONE; + }; + break; + + case FILE_TYPE_PIPE: /* a named or an anonymous pipe (socket already handled) */ + res = SELECT_HANDLE_PIPE; + break; + }; + }; + + CAMLreturnT(SELECTHANDLETYPE, res); +} + +/* Choose what to do with given data */ +LPSELECTDATA select_data_dispatch (LPSELECTDATA lpSelectData, SELECTMODE EMode, value fd, int lpOrigIdx) +{ + LPSELECTDATA res; + HANDLE hFileDescr; + struct sockaddr sa; + int sa_len; + BOOL alreadyAdded; + unsigned int uFlagsFd; + + CAMLparam1(fd); + + res = lpSelectData; + hFileDescr = Handle_val(fd); + sa_len = sizeof(sa); + alreadyAdded = FALSE; + uFlagsFd = Flags_fd_val(fd); + + DEBUG_PRINT("Begin dispatching handle %x", hFileDescr); + + DEBUG_PRINT("Waiting for %d on handle %x", EMode, hFileDescr); + + /* There is only 2 way to have except mode: transmission of OOB data through + a socket TCP/IP and through a strange interaction with a TTY. + With windows, we only consider the TCP/IP except condition + */ + switch(get_handle_type(fd)) + { + case SELECT_HANDLE_DISK: + DEBUG_PRINT("Handle %x is a disk handle", hFileDescr); + /* Disk is always ready in read/write operation */ + if (EMode == SELECT_MODE_READ || EMode == SELECT_MODE_WRITE) + { + res = static_poll_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd); + }; + break; + + case SELECT_HANDLE_CONSOLE: + DEBUG_PRINT("Handle %x is a console handle", hFileDescr); + /* Console is always ready in write operation, need to check for read. */ + if (EMode == SELECT_MODE_READ) + { + res = read_console_poll_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd); + } + else if (EMode == SELECT_MODE_WRITE) + { + res = static_poll_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd); + }; + break; + + case SELECT_HANDLE_PIPE: + DEBUG_PRINT("Handle %x is a pipe handle", hFileDescr); + /* Console is always ready in write operation, need to check for read. */ + if (EMode == SELECT_MODE_READ) + { + DEBUG_PRINT("Need to check availability of data on pipe"); + res = read_pipe_poll_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd); + } + else if (EMode == SELECT_MODE_WRITE) + { + DEBUG_PRINT("No need to check availability of data on pipe, write operation always possible"); + res = static_poll_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd); + }; + break; + + case SELECT_HANDLE_SOCKET: + DEBUG_PRINT("Handle %x is a socket handle", hFileDescr); + if (getsockname((SOCKET)hFileDescr, &sa, &sa_len) == SOCKET_ERROR) + { + if (WSAGetLastError() == WSAEINVAL) + { + /* Socket is not bound */ + DEBUG_PRINT("Socket is not connected"); + if (EMode == SELECT_MODE_WRITE || EMode == SELECT_MODE_READ) + { + res = static_poll_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd); + alreadyAdded = TRUE; + } + } + } + if (!alreadyAdded) + { + res = socket_poll_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd); + } + break; + + default: + DEBUG_PRINT("Handle %x is unknown", hFileDescr); + win32_maperr(ERROR_INVALID_HANDLE); + uerror("select", Nothing); + break; + }; + + DEBUG_PRINT("Finish dispatching handle %x", hFileDescr); + + CAMLreturnT(LPSELECTDATA, res); +} + +static DWORD caml_list_length (value lst) +{ + DWORD res; + + CAMLparam1 (lst); + CAMLlocal1 (l); + + for (res = 0, l = lst; l != Val_int(0); l = Field(l, 1), res++) + { } + + CAMLreturnT(DWORD, res); +} + +static value find_handle(LPSELECTRESULT iterResult, value readfds, value writefds, value exceptfds) +{ + CAMLparam3(readfds, writefds, exceptfds); + CAMLlocal2(result, list); + int i; + + switch( iterResult->EMode ) + { + case SELECT_MODE_READ: + list = readfds; + break; + case SELECT_MODE_WRITE: + list = writefds; + break; + case SELECT_MODE_EXCEPT: + list = exceptfds; + break; + }; + + for(i=0; list != Val_unit && i < iterResult->lpOrigIdx; ++i ) + { + list = Field(list, 1); + } + + if (list == Val_unit) + failwith ("select.c: original file handle not found"); + + result = Field(list, 0); + + CAMLreturn( result ); +} + +#define MAX(a, b) ((a) > (b) ? (a) : (b)) + +CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value timeout) +{ + /* Event associated to handle */ + DWORD nEventsCount; + DWORD nEventsMax; + HANDLE *lpEventsDone; + + /* Data for all handles */ + LPSELECTDATA lpSelectData; + LPSELECTDATA iterSelectData; + + /* Iterator for results */ + LPSELECTRESULT iterResult; + + /* Iterator */ + DWORD i; + + /* Error status */ + DWORD err; + + /* Time to wait */ + DWORD milliseconds; + + /* Is there static select data */ + BOOL hasStaticData = FALSE; + + /* Wait return */ + DWORD waitRet; + + /* Set of handle */ + SELECTHANDLESET hds; + DWORD hdsMax; + LPHANDLE hdsData; + + /* Length of each list */ + DWORD readfds_len; + DWORD writefds_len; + DWORD exceptfds_len; + + CAMLparam4 (readfds, writefds, exceptfds, timeout); + CAMLlocal5 (read_list, write_list, except_list, res, l); + CAMLlocal1 (fd); + + DEBUG_PRINT("in select"); + + nEventsCount = 0; + nEventsMax = 0; + lpEventsDone = NULL; + lpSelectData = NULL; + iterSelectData = NULL; + iterResult = NULL; + err = 0; + hasStaticData = 0; + waitRet = 0; + readfds_len = caml_list_length(readfds); + writefds_len = caml_list_length(writefds); + exceptfds_len = caml_list_length(exceptfds); + hdsMax = MAX(readfds_len, MAX(writefds_len, exceptfds_len)); + + hdsData = (HANDLE *)caml_stat_alloc(sizeof(HANDLE) * hdsMax); + + if (Double_val(timeout) >= 0.0) + { + milliseconds = 1000 * Double_val(timeout); + DEBUG_PRINT("Will wait %d ms", milliseconds); + } + else + { + milliseconds = INFINITE; + } + + + /* Create list of select data, based on the different list of fd to watch */ + DEBUG_PRINT("Dispatch read fd"); + handle_set_init(&hds, hdsData, hdsMax); + i=0; + for (l = readfds; l != Val_int(0); l = Field(l, 1)) + { + fd = Field(l, 0); + if (!handle_set_mem(&hds, Handle_val(fd))) + { + handle_set_add(&hds, Handle_val(fd)); + lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_READ, fd, i++); + } + else + { + DEBUG_PRINT("Discarding handle %x which is already monitor for read", Handle_val(fd)); + } + } + handle_set_reset(&hds); + + DEBUG_PRINT("Dispatch write fd"); + handle_set_init(&hds, hdsData, hdsMax); + i=0; + for (l = writefds; l != Val_int(0); l = Field(l, 1)) + { + fd = Field(l, 0); + if (!handle_set_mem(&hds, Handle_val(fd))) + { + handle_set_add(&hds, Handle_val(fd)); + lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_WRITE, fd, i++); + } + else + { + DEBUG_PRINT("Discarding handle %x which is already monitor for write", Handle_val(fd)); + } + } + handle_set_reset(&hds); + + DEBUG_PRINT("Dispatch exceptional fd"); + handle_set_init(&hds, hdsData, hdsMax); + i=0; + for (l = exceptfds; l != Val_int(0); l = Field(l, 1)) + { + fd = Field(l, 0); + if (!handle_set_mem(&hds, Handle_val(fd))) + { + handle_set_add(&hds, Handle_val(fd)); + lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_EXCEPT, fd, i++); + } + else + { + DEBUG_PRINT("Discarding handle %x which is already monitor for exceptional", Handle_val(fd)); + } + } + handle_set_reset(&hds); + + /* Building the list of handle to wait for */ + DEBUG_PRINT("Building events done array"); + nEventsMax = list_length((LPLIST)lpSelectData); + nEventsCount = 0; + lpEventsDone = (HANDLE *)caml_stat_alloc(sizeof(HANDLE) * nEventsMax); + + iterSelectData = lpSelectData; + while (iterSelectData != NULL) + { + /* Check if it is static data. If this is the case, launch everything + * but don't wait for events. It helps to test if there are events on + * any other fd (which are not static), knowing that there is at least + * one result (the static data). + */ + if (iterSelectData->EType == SELECT_TYPE_STATIC) + { + hasStaticData = TRUE; + }; + + /* Execute APC */ + if (iterSelectData->funcWorker != NULL) + { + iterSelectData->lpWorker = + worker_job_submit( + iterSelectData->funcWorker, + (void *)iterSelectData); + DEBUG_PRINT("Job submitted to worker %x", iterSelectData->lpWorker); + lpEventsDone[nEventsCount] = worker_job_event_done(iterSelectData->lpWorker); + nEventsCount++; + }; + iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData); + }; + + DEBUG_PRINT("Need to watch %d workers", nEventsCount); + + /* Processing select itself */ + enter_blocking_section(); + /* There are worker started, waiting to be monitored */ + if (nEventsCount > 0) + { + /* Waiting for event */ + if (err == 0 && !hasStaticData) + { + DEBUG_PRINT("Waiting for one select worker to be done"); + switch (WaitForMultipleObjects(nEventsCount, lpEventsDone, FALSE, milliseconds)) + { + case WAIT_FAILED: + err = GetLastError(); + break; + + case WAIT_TIMEOUT: + DEBUG_PRINT("Select timeout"); + break; + + default: + DEBUG_PRINT("One worker is done"); + break; + }; + } + + /* Ordering stop to every worker */ + DEBUG_PRINT("Sending stop signal to every select workers"); + iterSelectData = lpSelectData; + while (iterSelectData != NULL) + { + if (iterSelectData->lpWorker != NULL) + { + worker_job_stop(iterSelectData->lpWorker); + }; + iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData); + }; + + DEBUG_PRINT("Waiting for every select worker to be done"); + switch (WaitForMultipleObjects(nEventsCount, lpEventsDone, TRUE, INFINITE)) + { + case WAIT_FAILED: + err = GetLastError(); + break; + + default: + DEBUG_PRINT("Every worker is done"); + break; + } + } + /* Nothing to monitor but some time to wait. */ + else if (!hasStaticData) + { + Sleep(milliseconds); + } + leave_blocking_section(); + + DEBUG_PRINT("Error status: %d (0 is ok)", err); + /* Build results */ + if (err == 0) + { + DEBUG_PRINT("Building result"); + read_list = Val_unit; + write_list = Val_unit; + except_list = Val_unit; + + iterSelectData = lpSelectData; + while (iterSelectData != NULL) + { + for (i = 0; i < iterSelectData->nResultsCount; i++) + { + iterResult = &(iterSelectData->aResults[i]); + l = alloc_small(2, 0); + Store_field(l, 0, find_handle(iterResult, readfds, writefds, exceptfds)); + switch (iterResult->EMode) + { + case SELECT_MODE_READ: + Store_field(l, 1, read_list); + read_list = l; + break; + case SELECT_MODE_WRITE: + Store_field(l, 1, write_list); + write_list = l; + break; + case SELECT_MODE_EXCEPT: + Store_field(l, 1, except_list); + except_list = l; + break; + } + } + /* We try to only process the first error, bypass other errors */ + if (err == 0 && iterSelectData->EState == SELECT_STATE_ERROR) + { + err = iterSelectData->nError; + } + iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData); + } + } + + /* Free resources */ + DEBUG_PRINT("Free selectdata resources"); + iterSelectData = lpSelectData; + while (iterSelectData != NULL) + { + lpSelectData = iterSelectData; + iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData); + select_data_free(lpSelectData); + } + lpSelectData = NULL; + + /* Free allocated events/handle set array */ + DEBUG_PRINT("Free local allocated resources"); + caml_stat_free(lpEventsDone); + caml_stat_free(hdsData); + + DEBUG_PRINT("Raise error if required"); + if (err != 0) + { + win32_maperr(err); + uerror("select", Nothing); + } + + DEBUG_PRINT("Build final result"); + res = alloc_small(3, 0); + Store_field(res, 0, read_list); + Store_field(res, 1, write_list); + Store_field(res, 2, except_list); + + DEBUG_PRINT("out select"); + + CAMLreturn(res); +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/sendrecv.c b/ocaml-binary-annot/otherlibs/win32unix/sendrecv.c new file mode 100644 index 0000000000..855957bd4a --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/sendrecv.c @@ -0,0 +1,141 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy and Pascal Cuoq, 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <mlvalues.h> +#include <alloc.h> +#include <memory.h> +#include <signals.h> +#include "unixsupport.h" +#include "socketaddr.h" + +static int msg_flag_table[] = { + MSG_OOB, MSG_DONTROUTE, MSG_PEEK +}; + +CAMLprim value unix_recv(value sock, value buff, value ofs, value len, value flags) +{ + SOCKET s = Socket_val(sock); + int flg = convert_flag_list(flags, msg_flag_table); + int ret; + intnat numbytes; + char iobuf[UNIX_BUFFER_SIZE]; + DWORD err = 0; + + Begin_root (buff); + numbytes = Long_val(len); + if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; + enter_blocking_section(); + ret = recv(s, iobuf, (int) numbytes, flg); + if (ret == -1) err = WSAGetLastError(); + leave_blocking_section(); + if (ret == -1) { + win32_maperr(err); + uerror("recv", Nothing); + } + memmove (&Byte(buff, Long_val(ofs)), iobuf, ret); + End_roots(); + return Val_int(ret); +} + +CAMLprim value unix_recvfrom(value sock, value buff, value ofs, value len, value flags) +{ + SOCKET s = Socket_val(sock); + int flg = convert_flag_list(flags, msg_flag_table); + int ret; + intnat numbytes; + char iobuf[UNIX_BUFFER_SIZE]; + value res; + value adr = Val_unit; + union sock_addr_union addr; + socklen_param_type addr_len; + DWORD err = 0; + + Begin_roots2 (buff, adr); + numbytes = Long_val(len); + if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; + addr_len = sizeof(sock_addr); + enter_blocking_section(); + ret = recvfrom(s, iobuf, (int) numbytes, flg, &addr.s_gen, &addr_len); + if (ret == -1) err = WSAGetLastError(); + leave_blocking_section(); + if (ret == -1) { + win32_maperr(err); + uerror("recvfrom", Nothing); + } + memmove (&Byte(buff, Long_val(ofs)), iobuf, ret); + adr = alloc_sockaddr(&addr, addr_len, -1); + res = alloc_small(2, 0); + Field(res, 0) = Val_int(ret); + Field(res, 1) = adr; + End_roots(); + return res; +} + +CAMLprim value unix_send(value sock, value buff, value ofs, value len, value flags) +{ + SOCKET s = Socket_val(sock); + int flg = convert_flag_list(flags, msg_flag_table); + int ret; + intnat numbytes; + char iobuf[UNIX_BUFFER_SIZE]; + DWORD err = 0; + + numbytes = Long_val(len); + if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; + memmove (iobuf, &Byte(buff, Long_val(ofs)), numbytes); + enter_blocking_section(); + ret = send(s, iobuf, (int) numbytes, flg); + if (ret == -1) err = WSAGetLastError(); + leave_blocking_section(); + if (ret == -1) { + win32_maperr(err); + uerror("send", Nothing); + } + return Val_int(ret); +} + +value unix_sendto_native(value sock, value buff, value ofs, value len, value flags, value dest) +{ + SOCKET s = Socket_val(sock); + int flg = convert_flag_list(flags, msg_flag_table); + int ret; + intnat numbytes; + char iobuf[UNIX_BUFFER_SIZE]; + union sock_addr_union addr; + socklen_param_type addr_len; + DWORD err = 0; + + get_sockaddr(dest, &addr, &addr_len); + numbytes = Long_val(len); + if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; + memmove (iobuf, &Byte(buff, Long_val(ofs)), numbytes); + enter_blocking_section(); + ret = sendto(s, iobuf, (int) numbytes, flg, &addr.s_gen, addr_len); + if (ret == -1) err = WSAGetLastError(); + leave_blocking_section(); + if (ret == -1) { + win32_maperr(err); + uerror("sendto", Nothing); + } + return Val_int(ret); +} + +CAMLprim value unix_sendto(argv, argc) + value * argv; + int argc; +{ + return unix_sendto_native + (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/shutdown.c b/ocaml-binary-annot/otherlibs/win32unix/shutdown.c new file mode 100644 index 0000000000..f3d2c6e03f --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/shutdown.c @@ -0,0 +1,32 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy and Pascal Cuoq, 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <mlvalues.h> +#include "unixsupport.h" + +static int shutdown_command_table[] = { + 0, 1, 2 +}; + +CAMLprim value unix_shutdown(sock, cmd) + value sock, cmd; +{ + if (shutdown(Socket_val(sock), + shutdown_command_table[Int_val(cmd)]) == -1) { + win32_maperr(WSAGetLastError()); + uerror("shutdown", Nothing); + } + return Val_unit; +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/sleep.c b/ocaml-binary-annot/otherlibs/win32unix/sleep.c new file mode 100644 index 0000000000..421e5f9023 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/sleep.c @@ -0,0 +1,27 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <mlvalues.h> +#include <signals.h> +#include "unixsupport.h" + +CAMLprim value unix_sleep(t) + value t; +{ + enter_blocking_section(); + Sleep(Int_val(t) * 1000); + leave_blocking_section(); + return Val_unit; +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/socket.c b/ocaml-binary-annot/otherlibs/win32unix/socket.c new file mode 100644 index 0000000000..3cd55ec29f --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/socket.c @@ -0,0 +1,55 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy and Pascal Cuoq, 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <mlvalues.h> +#include "unixsupport.h" + +int socket_domain_table[] = { + PF_UNIX, PF_INET +}; + +int socket_type_table[] = { + SOCK_STREAM, SOCK_DGRAM, SOCK_RAW, SOCK_SEQPACKET +}; + +CAMLprim value unix_socket(domain, type, proto) + value domain, type, proto; +{ + SOCKET s; + int oldvalue, oldvaluelen, newvalue, retcode; + + oldvaluelen = sizeof(oldvalue); + retcode = getsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, + (char *) &oldvalue, &oldvaluelen); + if (retcode == 0) { + /* Set sockets to synchronous mode */ + newvalue = SO_SYNCHRONOUS_NONALERT; + setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, + (char *) &newvalue, sizeof(newvalue)); + } + s = socket(socket_domain_table[Int_val(domain)], + socket_type_table[Int_val(type)], + Int_val(proto)); + if (retcode == 0) { + /* Restore initial mode */ + setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, + (char *) &oldvalue, oldvaluelen); + } + if (s == INVALID_SOCKET) { + win32_maperr(WSAGetLastError()); + uerror("socket", Nothing); + } + return win_alloc_socket(s); +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/socketaddr.h b/ocaml-binary-annot/otherlibs/win32unix/socketaddr.h new file mode 100644 index 0000000000..8abc63b477 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/socketaddr.h @@ -0,0 +1,37 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <misc.h> + +union sock_addr_union { + struct sockaddr s_gen; + struct sockaddr_in s_inet; +}; + +extern union sock_addr_union sock_addr; + +#ifdef HAS_SOCKLEN_T +typedef socklen_t socklen_param_type; +#else +typedef int socklen_param_type; +#endif + +extern void get_sockaddr (value mladdr, + union sock_addr_union * addr /*out*/, + socklen_param_type * addr_len /*out*/); +CAMLprim value alloc_sockaddr (union sock_addr_union * addr /*in*/, + socklen_param_type addr_len, int close_on_error); +CAMLprim value alloc_inet_addr (struct in_addr * inaddr); +#define GET_INET_ADDR(v) (*((struct in_addr *) (v))) diff --git a/ocaml-binary-annot/otherlibs/win32unix/sockopt.c b/ocaml-binary-annot/otherlibs/win32unix/sockopt.c new file mode 100644 index 0000000000..f82d810e6e --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/sockopt.c @@ -0,0 +1,229 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy and Pascal Cuoq, 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <errno.h> +#include <mlvalues.h> +#include <memory.h> +#include <alloc.h> +#include <fail.h> +#include "unixsupport.h" +#include "socketaddr.h" + +#ifndef IPPROTO_IPV6 +#define IPPROTO_IPV6 (-1) +#endif +#ifndef IPV6_V6ONLY +#define IPV6_V6ONLY (-1) +#endif + +enum option_type { + TYPE_BOOL = 0, + TYPE_INT = 1, + TYPE_LINGER = 2, + TYPE_TIMEVAL = 3, + TYPE_UNIX_ERROR = 4 +}; + +struct socket_option { + int level; + int option; +}; + +/* Table of options, indexed by type */ + +static struct socket_option sockopt_bool[] = { + { SOL_SOCKET, SO_DEBUG }, + { SOL_SOCKET, SO_BROADCAST }, + { SOL_SOCKET, SO_REUSEADDR }, + { SOL_SOCKET, SO_KEEPALIVE }, + { SOL_SOCKET, SO_DONTROUTE }, + { SOL_SOCKET, SO_OOBINLINE }, + { SOL_SOCKET, SO_ACCEPTCONN }, + { IPPROTO_TCP, TCP_NODELAY }, + { IPPROTO_IPV6, IPV6_V6ONLY} +}; + +static struct socket_option sockopt_int[] = { + { SOL_SOCKET, SO_SNDBUF }, + { SOL_SOCKET, SO_RCVBUF }, + { SOL_SOCKET, SO_ERROR }, + { SOL_SOCKET, SO_TYPE }, + { SOL_SOCKET, SO_RCVLOWAT }, + { SOL_SOCKET, SO_SNDLOWAT } }; + +static struct socket_option sockopt_linger[] = { + { SOL_SOCKET, SO_LINGER } +}; + +static struct socket_option sockopt_timeval[] = { + { SOL_SOCKET, SO_RCVTIMEO }, + { SOL_SOCKET, SO_SNDTIMEO } +}; + +static struct socket_option sockopt_unix_error[] = { + { SOL_SOCKET, SO_ERROR } +}; + +static struct socket_option * sockopt_table[] = { + sockopt_bool, + sockopt_int, + sockopt_linger, + sockopt_timeval, + sockopt_unix_error +}; + +static char * getsockopt_fun_name[] = { + "getsockopt", + "getsockopt_int", + "getsockopt_optint", + "getsockopt_float", + "getsockopt_error" +}; + +static char * setsockopt_fun_name[] = { + "setsockopt", + "setsockopt_int", + "setsockopt_optint", + "setsockopt_float", + "setsockopt_error" +}; + +union option_value { + int i; + struct linger lg; + struct timeval tv; +}; + +CAMLexport value +unix_getsockopt_aux(char * name, + enum option_type ty, int level, int option, + value socket) +{ + union option_value optval; + socklen_param_type optsize; + + + switch (ty) { + case TYPE_BOOL: + case TYPE_INT: + case TYPE_UNIX_ERROR: + optsize = sizeof(optval.i); break; + case TYPE_LINGER: + optsize = sizeof(optval.lg); break; + case TYPE_TIMEVAL: + optsize = sizeof(optval.tv); break; + default: + unix_error(EINVAL, name, Nothing); + } + + if (getsockopt(Socket_val(socket), level, option, + (void *) &optval, &optsize) == -1) + uerror(name, Nothing); + + switch (ty) { + case TYPE_BOOL: + case TYPE_INT: + return Val_int(optval.i); + case TYPE_LINGER: + if (optval.lg.l_onoff == 0) { + return Val_int(0); /* None */ + } else { + value res = alloc_small(1, 0); /* Some */ + Field(res, 0) = Val_int(optval.lg.l_linger); + return res; + } + case TYPE_TIMEVAL: + return copy_double((double) optval.tv.tv_sec + + (double) optval.tv.tv_usec / 1e6); + case TYPE_UNIX_ERROR: + if (optval.i == 0) { + return Val_int(0); /* None */ + } else { + value err, res; + err = unix_error_of_code(optval.i); + Begin_root(err); + res = alloc_small(1, 0); /* Some */ + Field(res, 0) = err; + End_roots(); + return res; + } + default: + unix_error(EINVAL, name, Nothing); + return Val_unit; /* Avoid warning */ + } +} + +CAMLexport value +unix_setsockopt_aux(char * name, + enum option_type ty, int level, int option, + value socket, value val) +{ + union option_value optval; + socklen_param_type optsize; + double f; + + switch (ty) { + case TYPE_BOOL: + case TYPE_INT: + optsize = sizeof(optval.i); + optval.i = Int_val(val); + break; + case TYPE_LINGER: + optsize = sizeof(optval.lg); + optval.lg.l_onoff = Is_block (val); + if (optval.lg.l_onoff) + optval.lg.l_linger = Int_val (Field (val, 0)); + break; + case TYPE_TIMEVAL: + f = Double_val(val); + optsize = sizeof(optval.tv); + optval.tv.tv_sec = (int) f; + optval.tv.tv_usec = (int) (1e6 * (f - optval.tv.tv_sec)); + break; + case TYPE_UNIX_ERROR: + default: + unix_error(EINVAL, name, Nothing); + } + + if (setsockopt(Socket_val(socket), level, option, + (void *) &optval, optsize) == -1) + uerror(name, Nothing); + + return Val_unit; +} + +CAMLprim value unix_getsockopt(value vty, value vsocket, value voption) +{ + enum option_type ty = Int_val(vty); + struct socket_option * opt = &(sockopt_table[ty][Int_val(voption)]); + return unix_getsockopt_aux(getsockopt_fun_name[ty], + ty, + opt->level, + opt->option, + vsocket); +} + +CAMLprim value unix_setsockopt(value vty, value vsocket, value voption, + value val) +{ + enum option_type ty = Int_val(vty); + struct socket_option * opt = &(sockopt_table[ty][Int_val(voption)]); + return unix_setsockopt_aux(setsockopt_fun_name[ty], + ty, + opt->level, + opt->option, + vsocket, + val); +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/startup.c b/ocaml-binary-annot/otherlibs/win32unix/startup.c new file mode 100644 index 0000000000..8417e13669 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/startup.c @@ -0,0 +1,50 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy and Pascal Cuoq, 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 <stdio.h> +#include <fcntl.h> +#include <stdlib.h> +#include <mlvalues.h> +#include "unixsupport.h" +#include "winworker.h" +#include "windbug.h" + +value val_process_id; + +CAMLprim value win_startup(unit) + value unit; +{ + WSADATA wsaData; + int i; + HANDLE h; + + (void) WSAStartup(MAKEWORD(2, 0), &wsaData); + DuplicateHandle(GetCurrentProcess(), GetCurrentProcess(), + GetCurrentProcess(), &h, 0, TRUE, + DUPLICATE_SAME_ACCESS); + val_process_id = Val_int(h); + + worker_init(); + + return Val_unit; +} + +CAMLprim value win_cleanup(unit) + value unit; +{ + worker_cleanup(); + + (void) WSACleanup(); + + return Val_unit; +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/stat.c b/ocaml-binary-annot/otherlibs/win32unix/stat.c new file mode 100644 index 0000000000..79fc3b2eb7 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/stat.c @@ -0,0 +1,111 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2002 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <errno.h> +#include <mlvalues.h> +#include <memory.h> +#include <alloc.h> +#include "unixsupport.h" +#include "cst2constr.h" +#define _INTEGRAL_MAX_BITS 64 +#include <sys/types.h> +#include <sys/stat.h> + +#ifndef S_IFLNK +#define S_IFLNK 0 +#endif +#ifndef S_IFIFO +#define S_IFIFO 0 +#endif +#ifndef S_IFSOCK +#define S_IFSOCK 0 +#endif +#ifndef S_IFBLK +#define S_IFBLK 0 +#endif + +static int file_kind_table[] = { + S_IFREG, S_IFDIR, S_IFCHR, S_IFBLK, S_IFLNK, S_IFIFO, S_IFSOCK +}; + +static value stat_aux(int use_64, struct _stati64 *buf) +{ + CAMLparam0 (); + CAMLlocal1 (v); + + v = caml_alloc (12, 0); + Store_field (v, 0, Val_int (buf->st_dev)); + Store_field (v, 1, Val_int (buf->st_ino)); + Store_field (v, 2, cst_to_constr (buf->st_mode & S_IFMT, file_kind_table, + sizeof(file_kind_table) / sizeof(int), 0)); + Store_field (v, 3, Val_int(buf->st_mode & 07777)); + Store_field (v, 4, Val_int (buf->st_nlink)); + Store_field (v, 5, Val_int (buf->st_uid)); + Store_field (v, 6, Val_int (buf->st_gid)); + Store_field (v, 7, Val_int (buf->st_rdev)); + Store_field (v, 8, + use_64 ? copy_int64(buf->st_size) : Val_int (buf->st_size)); + Store_field (v, 9, copy_double((double) buf->st_atime)); + Store_field (v, 10, copy_double((double) buf->st_mtime)); + Store_field (v, 11, copy_double((double) buf->st_ctime)); + CAMLreturn (v); +} + +CAMLprim value unix_stat(value path) +{ + int ret; + struct _stati64 buf; + + ret = _stati64(String_val(path), &buf); + if (ret == -1) uerror("stat", path); + if (buf.st_size > Max_long) { + win32_maperr(ERROR_ARITHMETIC_OVERFLOW); + uerror("stat", path); + } + return stat_aux(0, &buf); +} + +CAMLprim value unix_stat_64(value path) +{ + int ret; + struct _stati64 buf; + ret = _stati64(String_val(path), &buf); + if (ret == -1) uerror("stat", path); + return stat_aux(1, &buf); +} + +CAMLprim value unix_fstat(value handle) +{ + int ret; + struct _stati64 buf; + + ret = _fstati64(win_CRT_fd_of_filedescr(handle), &buf); + if (ret == -1) uerror("fstat", Nothing); + if (buf.st_size > Max_long) { + win32_maperr(ERROR_ARITHMETIC_OVERFLOW); + uerror("fstat", Nothing); + } + return stat_aux(0, &buf); +} + +CAMLprim value unix_fstat_64(value handle) +{ + int ret; + struct _stati64 buf; + + ret = _fstati64(win_CRT_fd_of_filedescr(handle), &buf); + if (ret == -1) uerror("fstat", Nothing); + return stat_aux(1, &buf); +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/system.c b/ocaml-binary-annot/otherlibs/win32unix/system.c new file mode 100644 index 0000000000..51dc9bfb7b --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/system.c @@ -0,0 +1,44 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy and Pascal Cuoq, 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <mlvalues.h> +#include <memory.h> +#include <alloc.h> +#include <signals.h> +#include "unixsupport.h" +#include <process.h> +#include <stdio.h> + +CAMLprim value win_system(cmd) + value cmd; +{ + int ret; + value st; + char *buf; + intnat len; + + len = caml_string_length (cmd); + buf = caml_stat_alloc (len + 1); + memmove (buf, String_val (cmd), len + 1); + enter_blocking_section(); + _flushall(); + ret = system(buf); + leave_blocking_section(); + caml_stat_free(buf); + if (ret == -1) uerror("system", Nothing); + st = alloc_small(1, 0); /* Tag 0: Exited */ + Field(st, 0) = Val_int(ret); + return st; +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/unix.ml b/ocaml-binary-annot/otherlibs/win32unix/unix.ml new file mode 100644 index 0000000000..c8396d7fd4 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/unix.ml @@ -0,0 +1,945 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy and Pascal Cuoq, 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Initialization *) + +external startup: unit -> unit = "win_startup" +external cleanup: unit -> unit = "win_cleanup" + +let _ = startup(); at_exit cleanup + +(* Errors *) + +type error = + (* Errors defined in the POSIX standard *) + 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 *) + (* Additional errors, mostly BSD *) + | 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 + (* All other errors are mapped to EUNKNOWNERR *) + | EUNKNOWNERR of int (* Unknown error *) + +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 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 + +type file_descr + +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 waitpid : wait_flag list -> int -> int * process_status + = "win_waitpid" +external getpid : unit -> int = "unix_getpid" + +let fork () = invalid_arg "Unix.fork not implemented" +let wait () = invalid_arg "Unix.wait not implemented" +let getppid () = invalid_arg "Unix.getppid not implemented" +let nice prio = invalid_arg "Unix.nice not implemented" + +(* Basic file input/output *) + +external filedescr_of_fd : int -> file_descr = "win_handle_fd" + +let stdin = filedescr_of_fd 0 +let stdout = filedescr_of_fd 1 +let stderr = filedescr_of_fd 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 + +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 +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 + +(* Interfacing with the standard input/output library *) + +external in_channel_of_descr: file_descr -> in_channel = "win_inchannel_of_filedescr" +external out_channel_of_descr: file_descr -> out_channel = "win_outchannel_of_filedescr" +external descr_of_in_channel : in_channel -> file_descr = "win_filedescr_of_channel" +external descr_of_out_channel : out_channel -> file_descr = "win_filedescr_of_channel" + +(* Seeking and truncating *) + +type seek_command = + SEEK_SET + | SEEK_CUR + | SEEK_END + +external lseek : file_descr -> int -> seek_command -> int = "unix_lseek" + +let truncate name len = invalid_arg "Unix.truncate not implemented" +let ftruncate fd len = invalid_arg "Unix.ftruncate not implemented" + +(* File statistics *) + +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" +let lstat = stat +external fstat : file_descr -> stats = "unix_fstat" +let isatty fd = + match (fstat fd).st_kind with S_CHR -> true | _ -> false + +(* Operations on file names *) + +external unlink : string -> unit = "unix_unlink" +external rename : string -> string -> unit = "unix_rename" +external link : string -> string -> unit = "unix_link" + +(* Operations on large files *) + +module LargeFile = + struct + external lseek : file_descr -> int64 -> seek_command -> int64 = "unix_lseek_64" + let truncate name len = invalid_arg "Unix.LargeFile.truncate not implemented" + let ftruncate name len = invalid_arg "Unix.LargeFile.ftruncate not implemented" + 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" + let lstat = stat + external fstat : file_descr -> stats = "unix_fstat_64" + end + +(* File permissions and ownership *) + +type access_permission = + R_OK + | W_OK + | X_OK + | F_OK + +external chmod : string -> file_perm -> unit = "unix_chmod" +let fchmod fd perm = invalid_arg "Unix.fchmod not implemented" +let chown file perm = invalid_arg "Unix.chown not implemented" +let fchown fd perm = invalid_arg "Unix.fchown not implemented" +let umask msk = invalid_arg "Unix.umask not implemented" + +external access : string -> access_permission list -> unit = "unix_access" + +(* Operations on file descriptors *) + +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 = "win_set_close_on_exec" +external clear_close_on_exec : file_descr -> unit = "win_clear_close_on_exec" + +(* Directories *) + +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" +let chroot _ = invalid_arg "Unix.chroot not implemented" + +type dir_entry = + Dir_empty + | Dir_read of string + | Dir_toread + +type dir_handle = + { dirname: string; mutable handle: int; mutable entry_read: dir_entry } + +external findfirst : string -> string * int = "win_findfirst" +external findnext : int -> string= "win_findnext" + +let opendir dirname = + try + let (first_entry, handle) = findfirst (Filename.concat dirname "*.*") in + { dirname = dirname; handle = handle; entry_read = Dir_read first_entry } + with End_of_file -> + { dirname = dirname; handle = 0; entry_read = Dir_empty } + +let readdir d = + match d.entry_read with + Dir_empty -> raise End_of_file + | Dir_read name -> d.entry_read <- Dir_toread; name + | Dir_toread -> findnext d.handle + +external win_findclose : int -> unit = "win_findclose" + +let closedir d = + match d.entry_read with + Dir_empty -> () + | _ -> win_findclose d.handle + +let rewinddir d = + closedir d; + try + let (first_entry, handle) = findfirst (d.dirname ^ "\\*.*") in + d.handle <- handle; d.entry_read <- Dir_read first_entry + with End_of_file -> + d.handle <- 0; d.entry_read <- Dir_empty + +(* Pipes *) + +external pipe : unit -> file_descr * file_descr = "unix_pipe" + +let mkfifo name perm = invalid_arg "Unix.mkfifo not implemented" + +(* Symbolic links *) + +let readlink path = invalid_arg "Unix.readlink not implemented" +let symlink path1 path2 = invalid_arg "Unix.symlink not implemented" + +(* Locking *) + +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" +let kill pid signo = invalid_arg "Unix.kill not implemented" +type sigprocmask_command = SIG_SETMASK | SIG_BLOCK | SIG_UNBLOCK +let sigprocmask cmd sigs = invalid_arg "Unix.sigprocmask not implemented" +let sigpending () = invalid_arg "Unix.sigpending not implemented" +let sigsuspend sigs = invalid_arg "Unix.sigsuspend not implemented" +let pause () = invalid_arg "Unix.pause not implemented" + +(* Time functions *) + +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" +let alarm n = invalid_arg "Unix.alarm not implemented" +external sleep : int -> unit = "unix_sleep" +let times () = + { tms_utime = Sys.time(); tms_stime = 0.0; + tms_cutime = 0.0; tms_cstime = 0.0 } +external utimes : string -> float -> float -> unit = "unix_utimes" + +type interval_timer = + ITIMER_REAL + | ITIMER_VIRTUAL + | ITIMER_PROF + +type interval_timer_status = + { it_interval: float; + it_value: float } + +let getitimer it = invalid_arg "Unix.getitimer not implemented" +let setitimer it tm = invalid_arg "Unix.setitimer not implemented" + +(* User id, group id *) + +let getuid () = 1 +let geteuid = getuid +let setuid id = invalid_arg "Unix.setuid not implemented" + +let getgid () = 1 +let getegid = getgid +let setgid id = invalid_arg "Unix.setgid not implemented" + +let getgroups () = [|1|] +let setgroups _ = invalid_arg "Unix.setgroups not implemented" +let initgroups _ _ = invalid_arg "Unix.initgroups not implemented" + +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 } + +let getlogin () = try Sys.getenv "USERNAME" with Not_found -> "" +let getpwnam x = raise Not_found +let getgrnam = getpwnam +let getpwuid = getpwnam +let getgrgid = getpwnam + +(* Internet addresses *) + +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 + +(* Sockets *) + +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" +let socketpair dom ty proto = invalid_arg "Unix.socketpair not implemented" +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 + +(* Host and protocol databases *) + +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 + +let getaddrinfo 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) + +type name_info = + { ni_hostname : string; + ni_service : string } + +type getnameinfo_option = + NI_NOFQDN + | NI_NUMERICHOST + | NI_NAMEREQD + | NI_NUMERICSERV + | NI_DGRAM + +let getnameinfo 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 } + +(* High-level process management (system, popen) *) + +external win_create_process : string -> string -> string option -> + file_descr -> file_descr -> file_descr -> int + = "win_create_process" "win_create_process_native" + +let make_cmdline args = + let maybe_quote f = + if String.contains f ' ' || String.contains f '\"' + then Filename.quote f + else f in + String.concat " " (List.map maybe_quote (Array.to_list args)) + +let create_process prog args fd1 fd2 fd3 = + win_create_process prog (make_cmdline args) None fd1 fd2 fd3 + +let create_process_env prog args env fd1 fd2 fd3 = + win_create_process prog (make_cmdline args) + (Some(String.concat "\000" (Array.to_list env) ^ "\000")) + fd1 fd2 fd3 + +external system: string -> process_status = "win_system" + +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 optenv proc input output error = + let shell = + try Sys.getenv "COMSPEC" + with Not_found -> raise(Unix_error(ENOEXEC, "open_proc", cmd)) in + let pid = + win_create_process shell (shell ^ " /c " ^ cmd) optenv + input output error in + Hashtbl.add popen_processes proc pid + +let open_process_in cmd = + let (in_read, in_write) = pipe() in + set_close_on_exec in_read; + let inchan = in_channel_of_descr in_read in + open_proc cmd None (Process_in inchan) stdin in_write stderr; + close in_write; + inchan + +let open_process_out cmd = + let (out_read, out_write) = pipe() in + set_close_on_exec out_write; + let outchan = out_channel_of_descr out_write in + open_proc cmd None (Process_out outchan) out_read stdout stderr; + close out_read; + outchan + +let open_process cmd = + let (in_read, in_write) = pipe() in + let (out_read, out_write) = pipe() in + set_close_on_exec in_read; + set_close_on_exec out_write; + let inchan = in_channel_of_descr in_read in + let outchan = out_channel_of_descr out_write in + open_proc cmd None (Process(inchan, outchan)) out_read in_write stderr; + close out_read; close in_write; + (inchan, outchan) + +let open_process_full cmd env = + let (in_read, in_write) = pipe() in + let (out_read, out_write) = pipe() in + let (err_read, err_write) = pipe() in + set_close_on_exec in_read; + set_close_on_exec out_write; + set_close_on_exec err_read; + 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 cmd (Some(String.concat "\000" (Array.to_list env) ^ "\000")) + (Process_full(inchan, outchan, errchan)) + out_read in_write err_write; + close out_read; close in_write; close err_write; + (inchan, outchan, errchan) + +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 [] pid) + +let close_process_out outchan = + let pid = find_proc_id "close_process_out" (Process_out outchan) in + close_out outchan; + snd(waitpid [] pid) + +let close_process (inchan, outchan) = + let pid = find_proc_id "close_process" (Process(inchan, outchan)) in + close_in inchan; close_out outchan; + snd(waitpid [] 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; close_out outchan; close_in errchan; + snd(waitpid [] pid) + +(* Polling *) + +external select : + file_descr list -> file_descr list -> file_descr list -> float -> + file_descr list * file_descr list * file_descr list = "unix_select" + +(* High-level network functions *) + +let open_connection sockaddr = + let domain = + match sockaddr with ADDR_UNIX _ -> PF_UNIX | ADDR_INET(_,_) -> PF_INET in + let sock = + socket domain SOCK_STREAM 0 in + connect sock sockaddr; + (in_channel_of_descr sock, out_channel_of_descr sock) + +let shutdown_connection inchan = + shutdown (descr_of_in_channel inchan) SHUTDOWN_SEND + +let establish_server server_fun sockaddr = + invalid_arg "Unix.establish_server not implemented" + +(* Terminal interface *) + +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 + } + +type setattr_when = TCSANOW | TCSADRAIN | TCSAFLUSH + +let tcgetattr fd = invalid_arg "Unix.tcgetattr not implemented" +let tcsetattr fd wh = invalid_arg "Unix.tcsetattr not implemented" +let tcsendbreak fd n = invalid_arg "Unix.tcsendbreak not implemented" +let tcdrain fd = invalid_arg "Unix.tcdrain not implemented" + +type flush_queue = TCIFLUSH | TCOFLUSH | TCIOFLUSH +let tcflush fd q = invalid_arg "Unix.tcflush not implemented" +type flow_action = TCOOFF | TCOON | TCIOFF | TCION +let tcflow fd fl = invalid_arg "Unix.tcflow not implemented" +let setsid () = invalid_arg "Unix.setsid not implemented" diff --git a/ocaml-binary-annot/otherlibs/win32unix/unixsupport.c b/ocaml-binary-annot/otherlibs/win32unix/unixsupport.c new file mode 100644 index 0000000000..2f545c19f3 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/unixsupport.c @@ -0,0 +1,275 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <stddef.h> +#include <mlvalues.h> +#include <callback.h> +#include <alloc.h> +#include <memory.h> +#include <fail.h> +#include <custom.h> +#include "unixsupport.h" +#include "cst2constr.h" +#include <errno.h> + +/* Heap-allocation of Windows file handles */ + +static int win_handle_compare(value v1, value v2) +{ + HANDLE h1 = Handle_val(v1); + HANDLE h2 = Handle_val(v2); + return h1 == h2 ? 0 : h1 < h2 ? -1 : 1; +} + +static intnat win_handle_hash(value v) +{ + return (intnat) Handle_val(v); +} + +static struct custom_operations win_handle_ops = { + "_handle", + custom_finalize_default, + win_handle_compare, + win_handle_hash, + custom_serialize_default, + custom_deserialize_default +}; + +value win_alloc_handle(HANDLE h) +{ + value res = alloc_custom(&win_handle_ops, sizeof(struct filedescr), 0, 1); + Handle_val(res) = h; + Descr_kind_val(res) = KIND_HANDLE; + CRT_fd_val(res) = NO_CRT_FD; + Flags_fd_val(res) = 0; + return res; +} + +value win_alloc_socket(SOCKET s) +{ + value res = alloc_custom(&win_handle_ops, sizeof(struct filedescr), 0, 1); + Socket_val(res) = s; + Descr_kind_val(res) = KIND_SOCKET; + CRT_fd_val(res) = NO_CRT_FD; + Flags_fd_val(res) = 0; + return res; +} + +#if 0 +/* PR#4750: this function is no longer used */ +value win_alloc_handle_or_socket(HANDLE h) +{ + value res = win_alloc_handle(h); + int opt; + int optlen = sizeof(opt); + if (getsockopt((SOCKET) h, SOL_SOCKET, SO_TYPE, (char *)&opt, &optlen) == 0) + Descr_kind_val(res) = KIND_SOCKET; + return res; +} +#endif + +/* Mapping of Windows error codes to POSIX error codes */ + +struct error_entry { DWORD win_code; int range; int posix_code; }; + +static struct error_entry win_error_table[] = { + { ERROR_INVALID_FUNCTION, 0, EINVAL}, + { ERROR_FILE_NOT_FOUND, 0, ENOENT}, + { ERROR_PATH_NOT_FOUND, 0, ENOENT}, + { ERROR_TOO_MANY_OPEN_FILES, 0, EMFILE}, + { ERROR_ACCESS_DENIED, 0, EACCES}, + { ERROR_INVALID_HANDLE, 0, EBADF}, + { ERROR_ARENA_TRASHED, 0, ENOMEM}, + { ERROR_NOT_ENOUGH_MEMORY, 0, ENOMEM}, + { ERROR_INVALID_BLOCK, 0, ENOMEM}, + { ERROR_BAD_ENVIRONMENT, 0, E2BIG}, + { ERROR_BAD_FORMAT, 0, ENOEXEC}, + { ERROR_INVALID_ACCESS, 0, EINVAL}, + { ERROR_INVALID_DATA, 0, EINVAL}, + { ERROR_INVALID_DRIVE, 0, ENOENT}, + { ERROR_CURRENT_DIRECTORY, 0, EACCES}, + { ERROR_NOT_SAME_DEVICE, 0, EXDEV}, + { ERROR_NO_MORE_FILES, 0, ENOENT}, + { ERROR_LOCK_VIOLATION, 0, EACCES}, + { ERROR_BAD_NETPATH, 0, ENOENT}, + { ERROR_NETWORK_ACCESS_DENIED, 0, EACCES}, + { ERROR_BAD_NET_NAME, 0, ENOENT}, + { ERROR_FILE_EXISTS, 0, EEXIST}, + { ERROR_CANNOT_MAKE, 0, EACCES}, + { ERROR_FAIL_I24, 0, EACCES}, + { ERROR_INVALID_PARAMETER, 0, EINVAL}, + { ERROR_NO_PROC_SLOTS, 0, EAGAIN}, + { ERROR_DRIVE_LOCKED, 0, EACCES}, + { ERROR_BROKEN_PIPE, 0, EPIPE}, + { ERROR_NO_DATA, 0, EPIPE}, + { ERROR_DISK_FULL, 0, ENOSPC}, + { ERROR_INVALID_TARGET_HANDLE, 0, EBADF}, + { ERROR_INVALID_HANDLE, 0, EINVAL}, + { ERROR_WAIT_NO_CHILDREN, 0, ECHILD}, + { ERROR_CHILD_NOT_COMPLETE, 0, ECHILD}, + { ERROR_DIRECT_ACCESS_HANDLE, 0, EBADF}, + { ERROR_NEGATIVE_SEEK, 0, EINVAL}, + { ERROR_SEEK_ON_DEVICE, 0, EACCES}, + { ERROR_DIR_NOT_EMPTY, 0, ENOTEMPTY}, + { ERROR_NOT_LOCKED, 0, EACCES}, + { ERROR_BAD_PATHNAME, 0, ENOENT}, + { ERROR_MAX_THRDS_REACHED, 0, EAGAIN}, + { ERROR_LOCK_FAILED, 0, EACCES}, + { ERROR_ALREADY_EXISTS, 0, EEXIST}, + { ERROR_FILENAME_EXCED_RANGE, 0, ENOENT}, + { ERROR_NESTING_NOT_ALLOWED, 0, EAGAIN}, + { ERROR_NOT_ENOUGH_QUOTA, 0, ENOMEM}, + { ERROR_INVALID_STARTING_CODESEG, + ERROR_INFLOOP_IN_RELOC_CHAIN - ERROR_INVALID_STARTING_CODESEG, + ENOEXEC }, + { ERROR_WRITE_PROTECT, + ERROR_SHARING_BUFFER_EXCEEDED - ERROR_WRITE_PROTECT, + EACCES }, + { WSAEINVAL, 0, EINVAL }, + { WSAEACCES, 0, EACCES }, + { WSAEBADF, 0, EBADF }, + { WSAEFAULT, 0, EFAULT }, + { WSAEINTR, 0, EINTR }, + { WSAEINVAL, 0, EINVAL }, + { WSAEMFILE, 0, EMFILE }, +#ifdef WSANAMETOOLONG + { WSANAMETOOLONG, 0, ENAMETOOLONG }, +#endif +#ifdef WSAENFILE + { WSAENFILE, 0, ENFILE }, +#endif + { WSAENOTEMPTY, 0, ENOTEMPTY }, + { 0, -1, 0 } +}; + +void win32_maperr(DWORD errcode) +{ + int i; + + for (i = 0; win_error_table[i].range >= 0; i++) { + if (errcode >= win_error_table[i].win_code && + errcode <= win_error_table[i].win_code + win_error_table[i].range) { + errno = win_error_table[i].posix_code; + return; + } + } + /* Not found: save original error code, negated so that we can + recognize it in unix_error_message */ + errno = -errcode; +} + +/* Windows socket errors */ + +#define EWOULDBLOCK -WSAEWOULDBLOCK +#define EINPROGRESS -WSAEINPROGRESS +#define EALREADY -WSAEALREADY +#define ENOTSOCK -WSAENOTSOCK +#define EDESTADDRREQ -WSAEDESTADDRREQ +#define EMSGSIZE -WSAEMSGSIZE +#define EPROTOTYPE -WSAEPROTOTYPE +#define ENOPROTOOPT -WSAENOPROTOOPT +#define EPROTONOSUPPORT -WSAEPROTONOSUPPORT +#define ESOCKTNOSUPPORT -WSAESOCKTNOSUPPORT +#define EOPNOTSUPP -WSAEOPNOTSUPP +#define EPFNOSUPPORT -WSAEPFNOSUPPORT +#define EAFNOSUPPORT -WSAEAFNOSUPPORT +#define EADDRINUSE -WSAEADDRINUSE +#define EADDRNOTAVAIL -WSAEADDRNOTAVAIL +#define ENETDOWN -WSAENETDOWN +#define ENETUNREACH -WSAENETUNREACH +#define ENETRESET -WSAENETRESET +#define ECONNABORTED -WSAECONNABORTED +#define ECONNRESET -WSAECONNRESET +#define ENOBUFS -WSAENOBUFS +#define EISCONN -WSAEISCONN +#define ENOTCONN -WSAENOTCONN +#define ESHUTDOWN -WSAESHUTDOWN +#define ETOOMANYREFS -WSAETOOMANYREFS +#define ETIMEDOUT -WSAETIMEDOUT +#define ECONNREFUSED -WSAECONNREFUSED +#define ELOOP -WSAELOOP +#define EHOSTDOWN -WSAEHOSTDOWN +#define EHOSTUNREACH -WSAEHOSTUNREACH +#define EPROCLIM -WSAEPROCLIM +#define EUSERS -WSAEUSERS +#define EDQUOT -WSAEDQUOT +#define ESTALE -WSAESTALE +#define EREMOTE -WSAEREMOTE + +#define EOVERFLOW -ERROR_ARITHMETIC_OVERFLOW +#define EACCESS EACCES + +int error_table[] = { + E2BIG, EACCESS, 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; + + 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; +} + +void unix_error(int errcode, char *cmdname, value cmdarg) +{ + value res; + value name = Val_unit, err = Val_unit, arg = Val_unit; + int errconstr; + + 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(cmdname, cmdarg) + char * cmdname; + value cmdarg; +{ + unix_error(errno, cmdname, cmdarg); +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/unixsupport.h b/ocaml-binary-annot/otherlibs/win32unix/unixsupport.h new file mode 100644 index 0000000000..d56158304d --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/unixsupport.h @@ -0,0 +1,62 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy and Pascal Cuoq, 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#define WIN32_LEAN_AND_MEAN +#include <wtypes.h> +#include <winbase.h> +#include <stdlib.h> +#include <direct.h> +#include <process.h> +#include <sys/types.h> +#include <winsock.h> + +struct filedescr { + union { + HANDLE handle; + SOCKET socket; + } fd; /* Real windows handle */ + enum { KIND_HANDLE, KIND_SOCKET } kind; + int crt_fd; /* C runtime descriptor */ + unsigned int flags_fd; /* See FLAGS_FD_* */ +}; + +#define Handle_val(v) (((struct filedescr *) Data_custom_val(v))->fd.handle) +#define Socket_val(v) (((struct filedescr *) Data_custom_val(v))->fd.socket) +#define Descr_kind_val(v) (((struct filedescr *) Data_custom_val(v))->kind) +#define CRT_fd_val(v) (((struct filedescr *) Data_custom_val(v))->crt_fd) +#define Flags_fd_val(v) (((struct filedescr *) Data_custom_val(v))->flags_fd) + +/* extern value win_alloc_handle_or_socket(HANDLE); */ +extern value win_alloc_handle(HANDLE); +extern value win_alloc_socket(SOCKET); +extern int win_CRT_fd_of_filedescr(value handle); + +#define NO_CRT_FD (-1) +#define Nothing ((value) 0) + +extern void win32_maperr(DWORD errcode); +extern value unix_error_of_code (int errcode); +extern void unix_error (int errcode, char * cmdname, value arg); +extern void uerror (char * cmdname, value arg); +extern value unix_freeze_buffer (value); + +/* Information stored in flags_fd, describing more precisely the socket + * and its status. The whole flags_fd is initialized to 0. + */ + +/* Blocking or nonblocking. By default a filedescr is in blocking state */ +#define FLAGS_FD_IS_BLOCKING (1<<0) + +#define UNIX_BUFFER_SIZE 16384 diff --git a/ocaml-binary-annot/otherlibs/win32unix/windbug.c b/ocaml-binary-annot/otherlibs/win32unix/windbug.c new file mode 100644 index 0000000000..e3a2772dbf --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/windbug.c @@ -0,0 +1,32 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Contributed by Sylvain Le Gall for Lexifi */ +/* */ +/* Copyright 2008 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include "windbug.h" + +int debug_test (void) +{ + static int debug_init = 0; + static int debug = 0; + +#ifdef DEBUG + if (!debug_init) + { + debug = (getenv("OCAMLDEBUG") != NULL); + debug_init = 1; + }; +#endif + + return debug; +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/windbug.h b/ocaml-binary-annot/otherlibs/win32unix/windbug.h new file mode 100644 index 0000000000..69cbd3b6e9 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/windbug.h @@ -0,0 +1,38 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Contributed by Sylvain Le Gall for Lexifi */ +/* */ +/* Copyright 2008 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#ifdef DEBUG + +#include <stdio.h> +#include <windows.h> + +#define DEBUG_PRINT(fmt, ...) \ + do \ + { \ + if (debug_test()) \ + { \ + fprintf(stderr, "DBUG (pid:%d, tid: %d): ", GetCurrentProcessId(), GetCurrentThreadId()); \ + fprintf(stderr, fmt, __VA_ARGS__); \ + fprintf(stderr, "\n"); \ + fflush(stderr); \ + }; \ + } while(0) + +/* Test if we are in dbug mode */ +int debug_test (void); + +#else +#define DEBUG_PRINT(fmt, ...) +#endif diff --git a/ocaml-binary-annot/otherlibs/win32unix/windir.c b/ocaml-binary-annot/otherlibs/win32unix/windir.c new file mode 100644 index 0000000000..8b96589ec9 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/windir.c @@ -0,0 +1,79 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Pascal Cuoq and 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <mlvalues.h> +#include <memory.h> +#include <errno.h> +#include <alloc.h> +#include <fail.h> +#include "unixsupport.h" + +CAMLprim value win_findfirst(name) + value name; +{ + HANDLE h; + value v; + WIN32_FIND_DATA fileinfo; + value valname = Val_unit; + value valh = Val_unit; + + Begin_roots2 (valname,valh); + h = FindFirstFile(String_val(name),&fileinfo); + if (h == INVALID_HANDLE_VALUE) { + DWORD err = GetLastError(); + if (err == ERROR_NO_MORE_FILES) + raise_end_of_file(); + else { + win32_maperr(err); + uerror("opendir", Nothing); + } + } + valname = copy_string(fileinfo.cFileName); + valh = win_alloc_handle(h); + v = alloc_small(2, 0); + Field(v,0) = valname; + Field(v,1) = valh; + End_roots(); + return v; +} + +CAMLprim value win_findnext(valh) + value valh; +{ + WIN32_FIND_DATA fileinfo; + BOOL retcode; + + retcode = FindNextFile(Handle_val(valh), &fileinfo); + if (!retcode) { + DWORD err = GetLastError(); + if (err == ERROR_NO_MORE_FILES) + raise_end_of_file(); + else { + win32_maperr(err); + uerror("readdir", Nothing); + } + } + return copy_string(fileinfo.cFileName); +} + +CAMLprim value win_findclose(valh) + value valh; +{ + if (! FindClose(Handle_val(valh))) { + win32_maperr(GetLastError()); + uerror("closedir", Nothing); + } + return Val_unit; +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/winlist.c b/ocaml-binary-annot/otherlibs/win32unix/winlist.c new file mode 100644 index 0000000000..318a0addfd --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/winlist.c @@ -0,0 +1,80 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Contributed by Sylvain Le Gall for Lexifi */ +/* */ +/* Copyright 2008 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +/* Basic list function in C. */ + +#include "winlist.h" +#include <windows.h> + +void list_init (LPLIST lst) +{ + lst->lpNext = NULL; +} + +void list_cleanup (LPLIST lst) +{ + lst->lpNext = NULL; +} + +void list_next_set (LPLIST lst, LPLIST next) +{ + lst->lpNext = next; +} + +LPLIST list_next (LPLIST lst) +{ + return lst->lpNext; +} + +int list_length (LPLIST lst) +{ + int length = 0; + LPLIST iter = lst; + while (iter != NULL) + { + length++; + iter = list_next(iter); + }; + return length; +} + +LPLIST list_concat (LPLIST lsta, LPLIST lstb) +{ + LPLIST res = NULL; + LPLIST iter = NULL; + LPLIST iterPrev = NULL; + + if (lsta == NULL) + { + res = lstb; + } + else if (lstb == NULL) + { + res = lsta; + } + else + { + res = lsta; + iter = lsta; + while (iter != NULL) + { + iterPrev = iter; + iter = list_next(iter); + }; + iterPrev->lpNext = lstb; + }; + + return res; +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/winlist.h b/ocaml-binary-annot/otherlibs/win32unix/winlist.h new file mode 100644 index 0000000000..be388a4ca2 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/winlist.h @@ -0,0 +1,54 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Contributed by Sylvain Le Gall for Lexifi */ +/* */ +/* Copyright 2008 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ +#ifndef _WINLIST_H +#define _WINLIST_H + +/* Basic list function in C. */ + +/* Singly-linked list data structure. + * To transform a C struct into a list structure, you must include + * at first position of your C struct a "LIST lst" and call list_init + * on this data structure. + * + * See winworker.c for example. + */ +typedef struct _LIST LIST; +typedef LIST *LPLIST; + +struct _LIST { + LPLIST lpNext; +}; + +/* Initialize list data structure */ +void list_init (LPLIST lst); + +/* Cleanup list data structure */ +void list_cleanup (LPLIST lst); + +/* Set next element */ +void list_next_set (LPLIST lst, LPLIST next); + +/* Return next element */ +LPLIST list_next (LPLIST); + +#define LIST_NEXT(T, e) ((T)(list_next((LPLIST)(e)))) + +/* Get number of element */ +int list_length (LPLIST); + +/* Concat two list. */ +LPLIST list_concat (LPLIST, LPLIST); + +#endif /* _WINLIST_H */ diff --git a/ocaml-binary-annot/otherlibs/win32unix/winwait.c b/ocaml-binary-annot/otherlibs/win32unix/winwait.c new file mode 100644 index 0000000000..895a6926b8 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/winwait.c @@ -0,0 +1,70 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Pascal Cuoq and 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <windows.h> +#include <mlvalues.h> +#include <alloc.h> +#include <memory.h> +#include "unixsupport.h" +#include <sys/types.h> +#include <signals.h> + +static value alloc_process_status(HANDLE pid, int status) +{ + value res, st; + + st = alloc(1, 0); + Field(st, 0) = Val_int(status); + Begin_root (st); + res = alloc_small(2, 0); + Field(res, 0) = Val_long((intnat) pid); + Field(res, 1) = st; + End_roots(); + return res; +} + +enum { CAML_WNOHANG = 1, CAML_WUNTRACED = 2 }; + +static int wait_flag_table[] = { CAML_WNOHANG, CAML_WUNTRACED }; + +CAMLprim value win_waitpid(value vflags, value vpid_req) +{ + int flags; + DWORD status, retcode; + HANDLE pid_req = (HANDLE) Long_val(vpid_req); + DWORD err = 0; + + flags = convert_flag_list(vflags, wait_flag_table); + if ((flags & CAML_WNOHANG) == 0) { + enter_blocking_section(); + retcode = WaitForSingleObject(pid_req, INFINITE); + if (retcode == WAIT_FAILED) err = GetLastError(); + leave_blocking_section(); + if (err) { + win32_maperr(err); + uerror("waitpid", Nothing); + } + } + if (! GetExitCodeProcess(pid_req, &status)) { + win32_maperr(GetLastError()); + uerror("waitpid", Nothing); + } + if (status == STILL_ACTIVE) + return alloc_process_status((HANDLE) 0, 0); + else { + CloseHandle(pid_req); + return alloc_process_status(pid_req, status); + } +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/winworker.c b/ocaml-binary-annot/otherlibs/win32unix/winworker.c new file mode 100644 index 0000000000..57f95a9ae6 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/winworker.c @@ -0,0 +1,320 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Contributed by Sylvain Le Gall for Lexifi */ +/* */ +/* Copyright 2008 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include "winworker.h" +#include "winlist.h" +#include "windbug.h" +#include <mlvalues.h> +#include <alloc.h> +#include "unixsupport.h" + +typedef enum { + WORKER_CMD_NONE = 0, + WORKER_CMD_EXEC, + WORKER_CMD_STOP +} WORKERCMD; + +struct _WORKER { + LIST lst; /* This structure is used as a list. */ + HANDLE hJobStarted; /* Event representing that the function has begun. */ + HANDLE hJobStop; /* Event that can be used to notify the function that it + should stop processing. */ + HANDLE hJobDone; /* Event representing that the function has finished. */ + void *lpJobUserData; /* User data for the job. */ + WORKERFUNC hJobFunc; /* Function to be called during APC */ + HANDLE hWorkerReady; /* Worker is ready. */ + HANDLE hCommandReady; /* Worker should execute command. */ + WORKERCMD ECommand; /* Command to execute */ + HANDLE hThread; /* Thread handle of the worker. */ +}; + +#define THREAD_WORKERS_MAX 16 +#define THREAD_WORKERS_MEM 4000 + +LPWORKER lpWorkers = NULL; +DWORD nWorkersCurrent = 0; +DWORD nWorkersMax = 0; +HANDLE hWorkersMutex = INVALID_HANDLE_VALUE; + +DWORD WINAPI worker_wait (LPVOID _data) +{ + BOOL bExit; + LPWORKER lpWorker; + + lpWorker = (LPWORKER )_data; + bExit = FALSE; + + DEBUG_PRINT("Worker %x starting", lpWorker); + while ( + !bExit + && SignalObjectAndWait( + lpWorker->hWorkerReady, + lpWorker->hCommandReady, + INFINITE, + TRUE) == WAIT_OBJECT_0) + { + DEBUG_PRINT("Worker %x running", lpWorker); + switch (lpWorker->ECommand) + { + case WORKER_CMD_NONE: + break; + + case WORKER_CMD_EXEC: + if (lpWorker->hJobFunc != NULL) + { + SetEvent(lpWorker->hJobStarted); + lpWorker->hJobFunc(lpWorker->hJobStop, lpWorker->lpJobUserData); + SetEvent(lpWorker->hJobDone); + }; + break; + + case WORKER_CMD_STOP: + bExit = TRUE; + break; + } + }; + DEBUG_PRINT("Worker %x exiting", lpWorker); + + return 0; +} + +LPWORKER worker_new (void) +{ + LPWORKER lpWorker = NULL; + + lpWorker = (LPWORKER)caml_stat_alloc(sizeof(WORKER)); + list_init((LPLIST)lpWorker); + lpWorker->hJobStarted = CreateEvent(NULL, TRUE, FALSE, NULL); + lpWorker->hJobStop = CreateEvent(NULL, TRUE, FALSE, NULL); + lpWorker->hJobDone = CreateEvent(NULL, TRUE, FALSE, NULL); + lpWorker->lpJobUserData = NULL; + lpWorker->hWorkerReady = CreateEvent(NULL, FALSE, FALSE, NULL); + lpWorker->hCommandReady = CreateEvent(NULL, FALSE, FALSE, NULL); + lpWorker->ECommand = WORKER_CMD_NONE; + lpWorker->hThread = CreateThread( + NULL, + THREAD_WORKERS_MEM, + worker_wait, + (LPVOID)lpWorker, + 0, + NULL); + + return lpWorker; +}; + +void worker_free (LPWORKER lpWorker) +{ + /* Wait for termination of the worker */ + DEBUG_PRINT("Shutting down worker %x", lpWorker); + WaitForSingleObject(lpWorker->hWorkerReady, INFINITE); + lpWorker->ECommand = WORKER_CMD_STOP; + SetEvent(lpWorker->hCommandReady); + WaitForSingleObject(lpWorker->hThread, INFINITE); + + /* Free resources */ + DEBUG_PRINT("Freeing resources of worker %x", lpWorker); + if (lpWorker->hThread != INVALID_HANDLE_VALUE) + { + CloseHandle(lpWorker->hThread); + lpWorker->hThread = INVALID_HANDLE_VALUE; + } + + if (lpWorker->hJobStarted != INVALID_HANDLE_VALUE) + { + CloseHandle(lpWorker->hJobStarted); + lpWorker->hJobStarted = INVALID_HANDLE_VALUE; + } + + if (lpWorker->hJobStop != INVALID_HANDLE_VALUE) + { + CloseHandle(lpWorker->hJobStop); + lpWorker->hJobStop = INVALID_HANDLE_VALUE; + } + + if (lpWorker->hJobDone != INVALID_HANDLE_VALUE) + { + CloseHandle(lpWorker->hJobDone); + lpWorker->hJobDone = INVALID_HANDLE_VALUE; + } + + lpWorker->lpJobUserData = NULL; + lpWorker->hJobFunc = NULL; + + if (lpWorker->hWorkerReady != INVALID_HANDLE_VALUE) + { + CloseHandle(lpWorker->hWorkerReady); + lpWorker->hWorkerReady = INVALID_HANDLE_VALUE; + } + + if (lpWorker->hCommandReady != INVALID_HANDLE_VALUE) + { + CloseHandle(lpWorker->hCommandReady); + lpWorker->hCommandReady = INVALID_HANDLE_VALUE; + } + + caml_stat_free(lpWorker); +}; + +LPWORKER worker_pop (void) +{ + LPWORKER lpWorkerFree = NULL; + + WaitForSingleObject(hWorkersMutex, INFINITE); + /* Get the first worker of the list */ + if (lpWorkers != NULL) + { + lpWorkerFree = lpWorkers; + lpWorkers = LIST_NEXT(LPWORKER, lpWorkers); + } + nWorkersCurrent++; + nWorkersMax = (nWorkersCurrent > nWorkersMax ? nWorkersCurrent : nWorkersMax); + DEBUG_PRINT("Workers running current/runnning max/waiting: %d/%d/%d", + nWorkersCurrent, + nWorkersMax, + list_length((LPLIST)lpWorkers)); + ReleaseMutex(hWorkersMutex); + + if (lpWorkerFree == NULL) + { + /* We cannot find a free worker, create one. */ + lpWorkerFree = worker_new(); + } + + /* Ensure that we don't get dangling pointer to old data. */ + list_init((LPLIST)lpWorkerFree); + lpWorkerFree->lpJobUserData = NULL; + + /* Reset events */ + ResetEvent(lpWorkerFree->hJobStarted); + ResetEvent(lpWorkerFree->hJobStop); + ResetEvent(lpWorkerFree->hJobDone); + + return lpWorkerFree; +} + +void worker_push(LPWORKER lpWorker) +{ + BOOL bFreeWorker; + + bFreeWorker = TRUE; + + WaitForSingleObject(hWorkersMutex, INFINITE); + DEBUG_PRINT("Testing if we are under the maximum number of running workers"); + if (list_length((LPLIST)lpWorkers) < THREAD_WORKERS_MAX) + { + DEBUG_PRINT("Saving this worker for future use"); + DEBUG_PRINT("Next: %x", ((LPLIST)lpWorker)->lpNext); + lpWorkers = (LPWORKER)list_concat((LPLIST)lpWorker, (LPLIST)lpWorkers); + bFreeWorker = FALSE; + }; + nWorkersCurrent--; + DEBUG_PRINT("Workers running current/runnning max/waiting: %d/%d/%d", + nWorkersCurrent, + nWorkersMax, + list_length((LPLIST)lpWorkers)); + ReleaseMutex(hWorkersMutex); + + if (bFreeWorker) + { + DEBUG_PRINT("Freeing worker %x", lpWorker); + worker_free(lpWorker); + } +} + +void worker_init (void) +{ + int i = 0; + + /* Init a shared variable. The only way to ensure that no other + worker will be at the same point is to use a critical section. + */ + DEBUG_PRINT("Allocating mutex for workers"); + if (hWorkersMutex == INVALID_HANDLE_VALUE) + { + hWorkersMutex = CreateMutex(NULL, FALSE, NULL); + } +} + +void worker_cleanup(void) +{ + LPWORKER lpWorker = NULL; + + /* WARNING: we can have a race condition here, if while this code + is executed another worker is waiting to access hWorkersMutex, + he will never be able to get it... + */ + if (hWorkersMutex != INVALID_HANDLE_VALUE) + { + WaitForSingleObject(hWorkersMutex, INFINITE); + DEBUG_PRINT("Freeing global resource of workers"); + /* Empty the queue of worker worker */ + while (lpWorkers != NULL) + { + ReleaseMutex(hWorkersMutex); + lpWorker = worker_pop(); + DEBUG_PRINT("Freeing worker %x", lpWorker); + WaitForSingleObject(hWorkersMutex, INFINITE); + worker_free(lpWorker); + }; + ReleaseMutex(hWorkersMutex); + + /* Destroy associated mutex */ + CloseHandle(hWorkersMutex); + hWorkersMutex = INVALID_HANDLE_VALUE; + }; +} + +LPWORKER worker_job_submit (WORKERFUNC f, void *user_data) +{ + LPWORKER lpWorker = worker_pop(); + + DEBUG_PRINT("Waiting for worker to be ready"); + enter_blocking_section(); + WaitForSingleObject(lpWorker->hWorkerReady, INFINITE); + ResetEvent(lpWorker->hWorkerReady); + leave_blocking_section(); + DEBUG_PRINT("Worker is ready"); + + lpWorker->hJobFunc = f; + lpWorker->lpJobUserData = user_data; + lpWorker->ECommand = WORKER_CMD_EXEC; + + DEBUG_PRINT("Call worker (func: %x, worker: %x)", f, lpWorker); + SetEvent(lpWorker->hCommandReady); + + return (LPWORKER)lpWorker; +} + +HANDLE worker_job_event_done (LPWORKER lpWorker) +{ + return lpWorker->hJobDone; +} + +void worker_job_stop (LPWORKER lpWorker) +{ + DEBUG_PRINT("Sending stop signal to worker %x", lpWorker); + SetEvent(lpWorker->hJobStop); + DEBUG_PRINT("Signal sent to worker %x", lpWorker); +} + +void worker_job_finish (LPWORKER lpWorker) +{ + DEBUG_PRINT("Finishing call of worker %x", lpWorker); + enter_blocking_section(); + WaitForSingleObject(lpWorker->hJobDone, INFINITE); + leave_blocking_section(); + + worker_push(lpWorker); +} diff --git a/ocaml-binary-annot/otherlibs/win32unix/winworker.h b/ocaml-binary-annot/otherlibs/win32unix/winworker.h new file mode 100644 index 0000000000..06450a4ec3 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/winworker.h @@ -0,0 +1,70 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Contributed by Sylvain Le Gall for Lexifi */ +/* */ +/* Copyright 2008 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ +#ifndef _WINWORKER_H +#define _WINWORKER_H + +#define _WIN32_WINNT 0x0400 +#include <windows.h> + +/* Pool of worker threads. + * + * These functions help to manage a pool of worker thread and submit task to + * the pool. It helps to reduce the number of thread creation. + * + * Each worker are started in alertable wait state and jobs are submitted as + * APC (asynchronous procedure call). + */ + +/* Data associated with submitted job */ +typedef struct _WORKER WORKER; +typedef WORKER *LPWORKER; + +/* Function type of submitted job: + * void worker_call (HANDLE hStop, void *data) + * + * This function will be called using the data following: + * - hStop must be watched for change, since it represents an external command + * to stop the call. This event is shared through the WORKER structure, which + * can be access throuhg worker_job_event_done. + * - data is user provided data for the function. + */ +typedef void (*WORKERFUNC) (HANDLE, void *); + +/* Initialize global data structure for worker + */ +void worker_init (void); + +/* Free global data structure for worker + */ +void worker_cleanup (void); + +/* Submit a job to worker. Use returned data to synchronize with the procedure + * submitted. + */ +LPWORKER worker_job_submit (WORKERFUNC f, void *data); + +/* Get event to know when a job is done. + */ +HANDLE worker_job_event_done (LPWORKER); + +/* Ask a job to stop processing. + */ +void worker_job_stop (LPWORKER); + +/* End a job submitted to worker. + */ +void worker_job_finish (LPWORKER); + +#endif /* _WINWORKER_H */ diff --git a/ocaml-binary-annot/otherlibs/win32unix/write.c b/ocaml-binary-annot/otherlibs/win32unix/write.c new file mode 100644 index 0000000000..190d902539 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/win32unix/write.c @@ -0,0 +1,101 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <errno.h> +#include <string.h> +#include <mlvalues.h> +#include <memory.h> +#include <signals.h> +#include "unixsupport.h" + +CAMLprim value unix_write(value fd, value buf, value vofs, value vlen) +{ + intnat ofs, len, written; + DWORD numbytes, numwritten; + char iobuf[UNIX_BUFFER_SIZE]; + DWORD err = 0; + + Begin_root (buf); + ofs = Long_val(vofs); + len = Long_val(vlen); + written = 0; + while (len > 0) { + numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len; + memmove (iobuf, &Byte(buf, ofs), numbytes); + if (Descr_kind_val(fd) == KIND_SOCKET) { + int ret; + SOCKET s = Socket_val(fd); + enter_blocking_section(); + ret = send(s, iobuf, numbytes, 0); + if (ret == SOCKET_ERROR) err = WSAGetLastError(); + leave_blocking_section(); + numwritten = ret; + } else { + HANDLE h = Handle_val(fd); + enter_blocking_section(); + if (! WriteFile(h, iobuf, numbytes, &numwritten, NULL)) + err = GetLastError(); + leave_blocking_section(); + } + if (err) { + win32_maperr(err); + uerror("write", Nothing); + } + written += numwritten; + ofs += numwritten; + len -= numwritten; + } + End_roots(); + return Val_long(written); +} + +CAMLprim value unix_single_write(value fd, value buf, value vofs, value vlen) +{ + intnat ofs, len, written; + DWORD numbytes, numwritten; + char iobuf[UNIX_BUFFER_SIZE]; + DWORD err = 0; + + Begin_root (buf); + ofs = Long_val(vofs); + len = Long_val(vlen); + written = 0; + if (len > 0) { + numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len; + memmove (iobuf, &Byte(buf, ofs), numbytes); + if (Descr_kind_val(fd) == KIND_SOCKET) { + int ret; + SOCKET s = Socket_val(fd); + enter_blocking_section(); + ret = send(s, iobuf, numbytes, 0); + if (ret == SOCKET_ERROR) err = WSAGetLastError(); + leave_blocking_section(); + numwritten = ret; + } else { + HANDLE h = Handle_val(fd); + enter_blocking_section(); + if (! WriteFile(h, iobuf, numbytes, &numwritten, NULL)) + err = GetLastError(); + leave_blocking_section(); + } + if (err) { + win32_maperr(err); + uerror("single_write", Nothing); + } + written = numwritten; + } + End_roots(); + return Val_long(written); +} |