diff options
Diffstat (limited to 'otherlibs/win32unix')
29 files changed, 454 insertions, 195 deletions
diff --git a/otherlibs/win32unix/Makefile.nt b/otherlibs/win32unix/Makefile.nt index b39471001..3f811ed2b 100644 --- a/otherlibs/win32unix/Makefile.nt +++ b/otherlibs/win32unix/Makefile.nt @@ -8,18 +8,19 @@ CAMLC=..\..\boot\ocamlrun ..\..\boot\ocamlc -I ..\..\stdlib CAMLOPT=..\..\boot\ocamlrun ..\..\ocamlopt -I ..\..\stdlib # Files in this directory -WIN_OBJS = accept.obj bind.obj close_on.obj connect.obj \ - createprocess.obj getpeername.obj getpid.obj \ - getsockname.obj listen.obj mkdir.obj open.obj pipe.obj sendrecv.obj \ +WIN_OBJS = accept.obj bind.obj channels.obj close.obj \ + close_on.obj connect.obj createprocess.obj dup.obj dup2.obj \ + getpeername.obj getpid.obj getsockname.obj listen.obj lseek.obj \ + mkdir.obj open.obj pipe.obj read.obj sendrecv.obj \ shutdown.obj sleep.obj socket.obj sockopt.obj startup.obj system.obj \ - unixsupport.obj windir.obj winwait.obj + unixsupport.obj windir.obj winwait.obj write.obj # Files from the ..\unix directory -UNIX_FILES = access.c addrofstr.c chdir.c close.c cst2constr.c \ - cstringv.c dup.c dup2.c envir.c errmsg.c execv.c execve.c execvp.c \ +UNIX_FILES = access.c addrofstr.c chdir.c cst2constr.c \ + cstringv.c envir.c errmsg.c execv.c execve.c execvp.c \ exit.c getcwd.c gethost.c gethostname.c getproto.c \ - getserv.c gmtime.c lseek.c read.c rename.c rmdir.c \ - socketaddr.c stat.c strofaddr.c time.c unlink.c utimes.c write.c + getserv.c gmtime.c rename.c rmdir.c \ + socketaddr.c stat.c strofaddr.c time.c unlink.c utimes.c UNIX_OBJS = $(UNIX_FILES:.c=.obj) diff --git a/otherlibs/win32unix/README b/otherlibs/win32unix/README index a6fcc2f12..a84c16a91 100644 --- a/otherlibs/win32unix/README +++ b/otherlibs/win32unix/README @@ -1,6 +1,7 @@ This is a partial port of the Unix system interface to Win32. It was done as a summer project by Pascal Cuoq (ENS Lyon), -supervised by Xavier Leroy and Francois Rouaix (INRIA). +supervised by Xavier Leroy and Francois Rouaix (INRIA), then heavily +hacked by Xavier Leroy. See the interface file unix.mli in this directory for more documentation on the functions implemented. @@ -18,6 +19,12 @@ work around the following problems: socket handle fails under Windows 95. We've just removed the check on the handle type in the library. +The first problem no longer affects the Win32unix library. + +The second problem makes it impoosible, under Windows 95, to create an +in_channel or out_channel on a file descriptor opened on a socket, +using the in_channel_of_descr* and out_channel_of_descr*. + The diffs are included at the end of this file. They must be applied against a local copy of the libc sources found on the Visual C++ CD-ROM (in \msdev\crt\src). Then, rebuild the libraries and install them. diff --git a/otherlibs/win32unix/accept.c b/otherlibs/win32unix/accept.c index cbd7e1ed0..db0362714 100644 --- a/otherlibs/win32unix/accept.c +++ b/otherlibs/win32unix/accept.c @@ -20,33 +20,29 @@ value unix_accept(sock) /* ML */ value sock; { - SOCKET s; - value res; - int fd; + SOCKET sconn = (SOCKET) Handle_val(sock); + SOCKET snew; + value fd = Val_unit, adr = Val_unit, res; int optionValue; - HANDLE h; - value adr = Val_unit; /* Set sockets to synchronous mode */ optionValue = SO_SYNCHRONOUS_NONALERT; setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, (char *)&optionValue, sizeof(optionValue)); - Begin_root (adr); - sock_addr_len = sizeof(sock_addr); - enter_blocking_section(); - s = accept((SOCKET) _get_osfhandle(Int_val(sock)), - &sock_addr.s_gen, &sock_addr_len); - leave_blocking_section(); - if (s == INVALID_SOCKET) { - _dosmaperr(WSAGetLastError()); - uerror("accept", Nothing); - } + sock_addr_len = sizeof(sock_addr); + enter_blocking_section(); + snew = accept(sconn, &sock_addr.s_gen, &sock_addr_len); + leave_blocking_section(); + if (snew == INVALID_SOCKET) { + _dosmaperr(WSAGetLastError()); + uerror("accept", Nothing); + } + Begin_roots2 (fd, adr) + fd = win_alloc_handle((HANDLE) snew); adr = alloc_sockaddr(); res = alloc_tuple(2); - fd = _open_osfhandle(s, 0); - if (fd == -1) uerror("accept", Nothing); - Field(res, 0) = Val_int(fd); + Field(res, 0) = fd; Field(res, 1) = adr; End_roots(); return res; diff --git a/otherlibs/win32unix/bind.c b/otherlibs/win32unix/bind.c index e85a5c312..5af7da326 100644 --- a/otherlibs/win32unix/bind.c +++ b/otherlibs/win32unix/bind.c @@ -20,7 +20,10 @@ value unix_bind(socket, address) /* ML */ { int ret; get_sockaddr(address); - ret = bind(_get_osfhandle(Int_val(socket)), &sock_addr.s_gen, sock_addr_len); - if (ret == -1) uerror("bind", Nothing); + ret = bind((SOCKET) Handle_val(socket), &sock_addr.s_gen, sock_addr_len); + if (ret == -1) { + _dosmaperr(WSAGetLastError()); + uerror("bind", Nothing); + } return Val_unit; } diff --git a/otherlibs/win32unix/channels.c b/otherlibs/win32unix/channels.c new file mode 100644 index 000000000..d8160c1fc --- /dev/null +++ b/otherlibs/win32unix/channels.c @@ -0,0 +1,31 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* Automatique. Distributed only by permission. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <mlvalues.h> +#include "unixsupport.h" +#include <fcntl.h> + +static int open_descr_flags[10] = { + 0, 0, 0, 0, O_APPEND, 0, 0, 0, O_BINARY, O_TEXT +}; + +value win_fd_handle(value handle, value flags) /* ML */ +{ + return Val_int(_open_osfhandle(Handle_val(handle), + convert_flag_list(open_descr_flags, flags))); +} + +value win_handle_fd(value fd) /* ML */ +{ + return win_alloc_handle((HANDLE) _get_osfhandle(Int_val(fd))); +} diff --git a/otherlibs/win32unix/close.c b/otherlibs/win32unix/close.c new file mode 100644 index 000000000..dfc5a1f52 --- /dev/null +++ b/otherlibs/win32unix/close.c @@ -0,0 +1,24 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* Automatique. Distributed only by permission. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <mlvalues.h> +#include "unixsupport.h" + +value unix_close(value fd) /* ML */ +{ + if (! CloseHandle(Handle_val(fd))) { + _dosmaperr(GetLastError()); + uerror("close", Nothing); + } + return Val_unit; +} diff --git a/otherlibs/win32unix/close_on.c b/otherlibs/win32unix/close_on.c index 179a5ae48..a09399b1e 100644 --- a/otherlibs/win32unix/close_on.c +++ b/otherlibs/win32unix/close_on.c @@ -15,110 +15,30 @@ #include <windows.h> #include "unixsupport.h" -#if 0 - -/* This works only under Windows NT, but not 95 */ - -value win_set_close_on_exec(fd) /* ML */ - value fd; -{ - HANDLE h; - - h = (HANDLE) _get_osfhandle(Int_val(fd)) ; - if (h == (HANDLE) -1 || - ! SetHandleInformation(h, HANDLE_FLAG_INHERIT, 0)) { - _dosmaperr(GetLastError()); - uerror("set_close_on_exec", Nothing); - } - return Val_unit; -} - -value win_clear_close_on_exec(fd) /* ML */ - value fd; -{ - HANDLE h; - h = (HANDLE) _get_osfhandle(Int_val(fd)) ; - if (h == (HANDLE) -1 || - ! SetHandleInformation(h, HANDLE_FLAG_INHERIT, HANDLE_FLAG_INHERIT)) { - _dosmaperr(GetLastError()); - uerror("clear_close_on_exec", Nothing); - } - return Val_unit; -} - -#else - -/* This works on Win 95, but is a terrible hack. - Bug: the opening flags of the file descriptor (O_APPEND, O_TEXT) are lost. */ - -static int win_open_osfhandle2(handle, flags, reqd_fd) - HANDLE handle; - int flags; - int reqd_fd; -{ - int fd, retcode; - HANDLE new_handle; - - fd = _open_osfhandle((long)handle, flags); - if (fd == -1) - return -1; - if (fd == reqd_fd) - return 0; /* Got it! */ - /* Make a copy of the handle, since we're going to close "handle" when - we close "fd". */ - if (! DuplicateHandle(GetCurrentProcess(), handle, - GetCurrentProcess(), &new_handle, - 0L, FALSE, DUPLICATE_SAME_ACCESS)) { - _dosmaperr(GetLastError()); - return -1; - } - /* Keep fd open during the recursive call, thus forcing _open_osfhandle - to return reqd_fd eventually. */ - retcode = win_open_osfhandle2(new_handle, flags, reqd_fd); - close(fd); /* Also closes "handle" */ - return retcode; -} - -static int win_set_noninherit(fd) - int fd; +int win_set_inherit(value fd, BOOL inherit) { HANDLE oldh, newh; - oldh = (HANDLE) _get_osfhandle(fd); - if (oldh == (HANDLE) -1) return -1; + + oldh = Handle_val(fd); if (! DuplicateHandle(GetCurrentProcess(), oldh, GetCurrentProcess(), &newh, - 0L, FALSE, DUPLICATE_SAME_ACCESS)) { + 0L, inherit, DUPLICATE_SAME_ACCESS)) { _dosmaperr(GetLastError()); return -1; } - if (close(fd) == -1) return -1; - return win_open_osfhandle2(newh, 0, fd); + Handle_val(fd) = newh; + CloseHandle(oldh); + return 0; } -value win_set_close_on_exec(vfd) /* ML */ - value vfd; +value win_set_close_on_exec(value fd) /* ML */ { - if (win_set_noninherit(Int_val(vfd)) == -1) - uerror("set_close_on_exec", Nothing); + if (win_set_inherit(fd, FALSE) == -1) uerror("set_close_on_exec", Nothing); return Val_unit; } -value win_clear_close_on_exec(vfd) /* ML */ - value vfd; +value win_clear_close_on_exec(value fd) /* ML */ { - int fd, newfd; - - fd = Int_val(vfd); - newfd = dup(fd); - if (newfd == -1) { - uerror("clear_close_on_exec", Nothing); - } - if (dup2(newfd, fd) == -1) { - close(newfd); - uerror("clear_close_on_exec", Nothing); - } - close(newfd); + if (win_set_inherit(fd, TRUE) == -1) uerror("clear_close_on_exec", Nothing); return Val_unit; } - -#endif diff --git a/otherlibs/win32unix/connect.c b/otherlibs/win32unix/connect.c index 650d32b77..405eadabd 100644 --- a/otherlibs/win32unix/connect.c +++ b/otherlibs/win32unix/connect.c @@ -18,12 +18,12 @@ value unix_connect(socket, address) /* ML */ value socket, address; { + SOCKET s = (SOCKET) Handle_val(socket); int retcode; get_sockaddr(address); enter_blocking_section(); - retcode = connect((SOCKET)_get_osfhandle(Int_val(socket)), - &sock_addr.s_gen, sock_addr_len); + retcode = connect(s, &sock_addr.s_gen, sock_addr_len); leave_blocking_section(); if (retcode == -1) { _dosmaperr(WSAGetLastError()); diff --git a/otherlibs/win32unix/createprocess.c b/otherlibs/win32unix/createprocess.c index 8b3c935c0..ff07ba83e 100644 --- a/otherlibs/win32unix/createprocess.c +++ b/otherlibs/win32unix/createprocess.c @@ -18,8 +18,8 @@ /* From the Caml runtime */ extern char * searchpath(char * name); -value win_create_process_native(cmd, cmdline, env, fd1, fd2, fd3) - value cmd, cmdline, env, fd1, fd2, fd3; +value win_create_process_native(value cmd, value cmdline, value env, + value fd1, value fd2, value fd3) { PROCESS_INFORMATION pi; STARTUPINFO si; @@ -34,10 +34,9 @@ value win_create_process_native(cmd, cmdline, env, fd1, fd2, fd3) } GetStartupInfo(&si); si.dwFlags |= STARTF_USESTDHANDLES; - - si.hStdInput = (HANDLE) _get_osfhandle(Int_val(fd1)); - si.hStdOutput = (HANDLE) _get_osfhandle(Int_val(fd2)); - si.hStdError = (HANDLE) _get_osfhandle(Int_val(fd3)); + si.hStdInput = Handle_val(fd1); + si.hStdOutput = Handle_val(fd2); + si.hStdError = Handle_val(fd3); if (! CreateProcess(exefile, String_val(cmdline), NULL, NULL, TRUE, 0, envp, NULL, &si, &pi)) { _dosmaperr(GetLastError()); @@ -46,9 +45,7 @@ value win_create_process_native(cmd, cmdline, env, fd1, fd2, fd3) return Val_int(pi.hProcess); } -value win_create_process(argv, argn) /* ML */ - value * argv; - int argn; +value win_create_process(value * argv, int argn) /* ML */ { return win_create_process_native(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); diff --git a/otherlibs/win32unix/dup.c b/otherlibs/win32unix/dup.c new file mode 100644 index 000000000..95f517e95 --- /dev/null +++ b/otherlibs/win32unix/dup.c @@ -0,0 +1,28 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* Automatique. Distributed only by permission. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <mlvalues.h> +#include "unixsupport.h" + +value unix_dup(value fd) /* ML */ +{ + HANDLE newh; + if (! DuplicateHandle(GetCurrentProcess(), Handle_val(fd), + GetCurrentProcess(), &newh, + 0L, inherit, DUPLICATE_SAME_ACCESS)) { + _dosmaperr(GetLastError()); + return -1; + } + return win_alloc_handle(newh); +} + diff --git a/otherlibs/win32unix/dup2.c b/otherlibs/win32unix/dup2.c new file mode 100644 index 000000000..a7eb8ee91 --- /dev/null +++ b/otherlibs/win32unix/dup2.c @@ -0,0 +1,31 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* Automatique. Distributed only by permission. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <mlvalues.h> +#include "unixsupport.h" + +value unix_dup2(value fd1, value fd2) /* ML */ +{ + HANDLE oldh, newh; + + oldh = Handle_val(fd2); + if (! DuplicateHandle(GetCurrentProcess(), Handle_val(fd1), + GetCurrentProcess(), &newh, + 0L, inherit, DUPLICATE_SAME_ACCESS)) { + _dosmaperr(GetLastError()); + return -1; + } + Handle_val(fd2) = newh; + CloseHandle(oldh); + return Val_unit; +} diff --git a/otherlibs/win32unix/getpeername.c b/otherlibs/win32unix/getpeername.c index 2921d3a70..60e739216 100644 --- a/otherlibs/win32unix/getpeername.c +++ b/otherlibs/win32unix/getpeername.c @@ -21,7 +21,7 @@ value unix_getpeername(sock) /* ML */ int retcode; sock_addr_len = sizeof(sock_addr); - retcode = getpeername(_get_osfhandle(Int_val(sock)), + retcode = getpeername((SOCKET) Handle_val(sock), &sock_addr.s_gen, &sock_addr_len); if (retcode == -1) { _dosmaperr(WSAGetLastError()); diff --git a/otherlibs/win32unix/getsockname.c b/otherlibs/win32unix/getsockname.c index 156939e26..cf18ebf57 100644 --- a/otherlibs/win32unix/getsockname.c +++ b/otherlibs/win32unix/getsockname.c @@ -21,7 +21,7 @@ value unix_getsockname(sock) /* ML */ int retcode; sock_addr_len = sizeof(sock_addr); - retcode = getsockname((SOCKET) _get_osfhandle(Int_val(sock)), + retcode = getsockname((SOCKET) Handle_val(sock), &sock_addr.s_gen, &sock_addr_len); if (retcode == -1) uerror("getsockname", Nothing); return alloc_sockaddr(); diff --git a/otherlibs/win32unix/listen.c b/otherlibs/win32unix/listen.c index 15e8334e3..aafcc9b99 100644 --- a/otherlibs/win32unix/listen.c +++ b/otherlibs/win32unix/listen.c @@ -18,7 +18,9 @@ value unix_listen(sock, backlog) /* ML */ value sock, backlog; { - if (listen((SOCKET) _get_osfhandle(Int_val(sock)), Int_val(backlog)) == -1) + if (listen((SOCKET) Handle_val(sock), Int_val(backlog)) == -1) { + _dosmaperr(WSAGetLastError()); uerror("listen", Nothing); + } return Val_unit; } diff --git a/otherlibs/win32unix/lseek.c b/otherlibs/win32unix/lseek.c new file mode 100644 index 000000000..befd87ab2 --- /dev/null +++ b/otherlibs/win32unix/lseek.c @@ -0,0 +1,39 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* Automatique. Distributed only by permission. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <mlvalues.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 int seek_command_table[] = { + FILE_BEGIN, FILE_CURRENT, FILE_END +}; + +value unix_lseek(value fd, value ofs, value cmd) /* ML */ +{ + long ret; + ret = SetFilePointer(Handle_val(fd), Long_val(ofs), NULL, + seek_command_table[Int_val(cmd)]); + if (ret == -1) { + _dosmaperr(GetLastError()); + uerror("lseek", Nothing); + } + return Val_long(ret); +} diff --git a/otherlibs/win32unix/open.c b/otherlibs/win32unix/open.c index 248e7018b..63e370392 100644 --- a/otherlibs/win32unix/open.c +++ b/otherlibs/win32unix/open.c @@ -16,22 +16,37 @@ #include "unixsupport.h" #include <fcntl.h> -static int open_flag_table[] = { - O_RDONLY, O_WRONLY, O_RDWR, 0, O_APPEND, O_CREAT, O_TRUNC, O_EXCL, 0, 0 +static int open_access_flags[10] = { + GENERIC_READ, GENERIC_WRITE, GENERIC_READ|GENERIC_WRITE, 0, 0, 0, 0, 0, 0, 0 }; -static int open_text_flag_table[] = { - 0, 0, 0, 0, 0, 0, 0, 0, 0, 1 +static int open_create_flags[10] = { + 0, 0, 0, 0, 0, O_CREAT, O_TRUNC, O_EXCL, 0, 0 }; -value unix_open(path, flags, perm) /* ML */ - value path, flags, perm; +value unix_open(value path, value flags, value perm) /* ML */ { - int fl, ret; + int fileaccess, createflags, fileattrib; + HANDLE h; - fl = convert_flag_list(flags, open_flag_table); - if (convert_flag_list(flags, open_text_flag_table) == 0) fl |= O_BINARY; - ret = open(String_val(path), fl, Int_val(perm)); - if (ret == -1) uerror("open", path); - return Val_int(ret); + 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; + h = CreateFile(String_val(path), fileaccess, 0, NULL, + filecreate, fileattrib, NULL); + if (h == INVALID_HANDLE_VALUE) uerror("open", path); + return win_alloc_handle(h); } diff --git a/otherlibs/win32unix/pipe.c b/otherlibs/win32unix/pipe.c index d5e17ca54..c782f7afa 100644 --- a/otherlibs/win32unix/pipe.c +++ b/otherlibs/win32unix/pipe.c @@ -17,15 +17,22 @@ #include <fcntl.h> #define SIZEBUF 1024 -#define MODE O_BINARY -value unix_pipe() /* ML */ +value unix_pipe(value unit) /* ML */ { - int fd[2]; - value res; - if (_pipe(fd, SIZEBUF, MODE) == -1) uerror("pipe", Nothing); - res = alloc_tuple(2); - Field(res, 0) = Val_int(fd[0]); - Field(res, 1) = Val_int(fd[1]); + HANDLE readh, writeh; + value readfd = Val_unit, writefd = Val_unit, res; + + if (! CreatePipe(&readh, &writeh, NULL, SIZEBUF)) { + _dosmaperr(GetLastError()); + uerror("pipe", Nothing); + } + Begin_roots2(readfd, writefd) + readfd = win_alloc_handle(readh); + writefd = win_alloc_handle(writeh); + res = alloc_tuple(2); + Field(res, 0) = readfd; + Field(res, 1) = writefd; + End_roots(); return res; } diff --git a/otherlibs/win32unix/read.c b/otherlibs/win32unix/read.c new file mode 100644 index 000000000..dd8aa74e2 --- /dev/null +++ b/otherlibs/win32unix/read.c @@ -0,0 +1,40 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* Automatique. Distributed only by permission. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <string.h> +#include <mlvalues.h> +#include <memory.h> +#include <signals.h> +#include "unixsupport.h" + +value unix_read(value fd, value buf, value ofs, value len) /* ML */ +{ + DWORD numbytes, numread; + BOOL ret; + char iobuf[UNIX_BUFFER_SIZE]; + HANDLE h = Handle_val(fd); + + Begin_root (buf); + numbytes = Long_val(len); + if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; + enter_blocking_section(); + ret = ReadFile(h, iobuf, numbytes, &numread, NULL); + leave_blocking_section(); + if (! ret) { + _dosmaperr(GetLastError()); + uerror("read", Nothing); + } + bcopy(iobuf, &Byte(buf, Long_val(ofs)), numread); + End_roots(); + return Val_int(numread); +} diff --git a/otherlibs/win32unix/sendrecv.c b/otherlibs/win32unix/sendrecv.c index a1818a478..86ab62348 100644 --- a/otherlibs/win32unix/sendrecv.c +++ b/otherlibs/win32unix/sendrecv.c @@ -31,10 +31,13 @@ value unix_recv(value sock, value buff, value ofs, value len, value flags) numbytes = Long_val(len); if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; enter_blocking_section(); - ret = recv((SOCKET) _get_osfhandle(Int_val(sock)), iobuf, (int) numbytes, + ret = recv((SOCKET) Handle_val(sock), iobuf, (int) numbytes, convert_flag_list(flags, msg_flag_table)); leave_blocking_section(); - if (ret == -1) uerror("recv", Nothing); + if (ret == -1) { + _dosmaperr(WSAGetLastError()); + uerror("recv", Nothing); + } bcopy(iobuf, &Byte(buff, Long_val(ofs)), ret); End_roots(); return Val_int(ret); @@ -53,12 +56,15 @@ value unix_recvfrom(value sock, value buff, value ofs, value len, value flags) / if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; sock_addr_len = sizeof(sock_addr); enter_blocking_section(); - ret = recvfrom((SOCKET) _get_osfhandle(Int_val(sock)), + ret = recvfrom((SOCKET) Handle_val(sock), iobuf, (int) numbytes, convert_flag_list(flags, msg_flag_table), &sock_addr.s_gen, &sock_addr_len); leave_blocking_section(); - if (ret == -1) uerror("recvfrom", Nothing); + if (ret == -1) { + _dosmaperr(WSAGetLastError()); + uerror("recvfrom", Nothing); + } bcopy(iobuf, &Byte(buff, Long_val(ofs)), ret); adr = alloc_sockaddr(); res = alloc_tuple(2); @@ -78,10 +84,13 @@ value unix_send(value sock, value buff, value ofs, value len, value flags) /* ML if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; bcopy(&Byte(buff, Long_val(ofs)), iobuf, numbytes); enter_blocking_section(); - ret = send((SOCKET) _get_osfhandle(Int_val(sock)), iobuf, (int) numbytes, + ret = send((SOCKET) Handle_val(sock), iobuf, (int) numbytes, convert_flag_list(flags, msg_flag_table)); leave_blocking_section(); - if (ret == -1) uerror("send", Nothing); + if (ret == -1) { + _dosmaperr(WSAGetLastError()); + uerror("send", Nothing); + } return Val_int(ret); } @@ -96,12 +105,15 @@ value unix_sendto_native(value sock, value buff, value ofs, value len, value fla if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; bcopy(&Byte(buff, Long_val(ofs)), iobuf, numbytes); enter_blocking_section(); - ret = sendto((SOCKET) _get_osfhandle(Int_val(sock)), + ret = sendto((SOCKET) Handle_val(sock), iobuf, (int) numbytes, convert_flag_list(flags, msg_flag_table), &sock_addr.s_gen, sock_addr_len); leave_blocking_section(); - if (ret == -1) uerror("sendto", Nothing); + if (ret == -1) { + _dosmaperr(WSAGetLastError()); + uerror("sendto", Nothing); + } return Val_int(ret); } diff --git a/otherlibs/win32unix/shutdown.c b/otherlibs/win32unix/shutdown.c index 914a54247..313ab5e31 100644 --- a/otherlibs/win32unix/shutdown.c +++ b/otherlibs/win32unix/shutdown.c @@ -22,8 +22,10 @@ static int shutdown_command_table[] = { value unix_shutdown(sock, cmd) /* ML */ value sock, cmd; { - if (shutdown((SOCKET) _get_osfhandle(Int_val(sock)), - shutdown_command_table[Int_val(cmd)]) == -1) + if (shutdown((SOCKET) Handle_val(sock), + shutdown_command_table[Int_val(cmd)]) == -1) { + _dosmaperr(WSAGetLastError()); uerror("shutdown", Nothing); + } return Val_unit; } diff --git a/otherlibs/win32unix/socket.c b/otherlibs/win32unix/socket.c index 05b6a096c..0ccace588 100644 --- a/otherlibs/win32unix/socket.c +++ b/otherlibs/win32unix/socket.c @@ -42,5 +42,5 @@ value unix_socket(domain, type, proto) /* ML */ _dosmaperr(WSAGetLastError()); uerror("socket", Nothing); } - return Val_int(_open_osfhandle(s, 0)); + return win_alloc_handle((HANDLE) s); } diff --git a/otherlibs/win32unix/sockopt.c b/otherlibs/win32unix/sockopt.c index c858627a5..8ce59d8b2 100644 --- a/otherlibs/win32unix/sockopt.c +++ b/otherlibs/win32unix/sockopt.c @@ -25,9 +25,11 @@ value unix_getsockopt(socket, option) /* ML */ { int optval, optsize; optsize = sizeof(optval); - if (getsockopt(_get_osfhandle(Int_val(socket)), SOL_SOCKET, - sockopt[Int_val(option)], (char *) &optval, &optsize) == -1) + if (getsockopt((SOCKET) Handle_val(socket), SOL_SOCKET, + sockopt[Int_val(option)], (char *) &optval, &optsize) == -1) { + _dosmaperr(WSAGetLastError()); uerror("getsockopt", Nothing); + } return Val_int(optval); } @@ -35,9 +37,11 @@ value unix_setsockopt(socket, option, status) /* ML */ value socket, option, status; { int optval = Int_val(status); - if (setsockopt(_get_osfhandle(Int_val(socket)), SOL_SOCKET, + if (setsockopt((SOCKET) Handle_val(socket), SOL_SOCKET, sockopt[Int_val(option)], - (char *) &optval, sizeof(optval)) == -1) + (char *) &optval, sizeof(optval)) == -1) { + _dosmaperr(WSAGetLastError()); uerror("setsockopt", Nothing); + } return Val_unit; } diff --git a/otherlibs/win32unix/startup.c b/otherlibs/win32unix/startup.c index ef11de0c9..af8919f18 100644 --- a/otherlibs/win32unix/startup.c +++ b/otherlibs/win32unix/startup.c @@ -40,3 +40,7 @@ value win_cleanup(unit) /* ML */ return Val_unit; } +value win_stdhandle(value nhandle) /* ML */ +{ + return win_alloc_handle(GetStdHandle(Int_val(nhandle))); +} diff --git a/otherlibs/win32unix/unix.ml b/otherlibs/win32unix/unix.ml index 5fa71cec9..b7d649b66 100644 --- a/otherlibs/win32unix/unix.ml +++ b/otherlibs/win32unix/unix.ml @@ -125,7 +125,7 @@ type wait_flag = WNOHANG | WUNTRACED -type file_descr = int +type file_descr external execv : string -> string array -> unit = "unix_execv" external execve : string -> string array -> string array -> unit = "unix_execve" @@ -135,9 +135,11 @@ external waitpid : wait_flag list -> int -> int * process_status = "win_waitpid" external getpid : unit -> int = "unix_getpid" -let stdin = 0 -let stdout = 1 -let stderr = 2 +external stdhandle : int -> file_descr = "win_stdhandle" + +let stdin = stdhandle 0 +let stdout = stdhandle 1 +let stderr = stdhandle 2 type open_flag = O_RDONLY @@ -170,13 +172,27 @@ let write fd buf ofs len = then invalid_arg "Unix.write" else unsafe_write fd buf ofs len -external in_channel_of_descr : file_descr -> in_channel - = "caml_open_descriptor" -external out_channel_of_descr : file_descr -> out_channel - = "caml_open_descriptor" -external descr_of_in_channel : in_channel -> file_descr = "channel_descriptor" -external descr_of_out_channel : out_channel -> file_descr - = "channel_descriptor" +external open_read_descriptor : int -> in_channel = "caml_open_descriptor" +external open_write_descriptor : int -> out_channel = "caml_open_descriptor" +external fd_of_in_channel : in_channel -> file_descr = "channel_descriptor" +external fd_of_out_channel : out_channel -> file_descr = "channel_descriptor" + +external open_handle : file_descr -> open_flags list -> int = "win_fd_handle" +external filedescr_of_fd : int -> file_descr = "win_handle_fd" + +let in_channel_of_descr_gen flags handle = + open_read_descriptor(open_handle handle flags) +let in_channel_of_descr handle = in_channel_of_descr_gen [O_TEXT] + +let out_channel_of_descr_gen flags handle = + open_write_descriptor(open_handle handle flags) +let out_channel_of_descr handle = out_channel_of_descr_gen [O_TEXT] + +let descr_of_in_channel inchan = + filedescr_of_fd(fd_of_in_channel inchan) + +let descr_of_out_channel outchan = + filedescr_of_fd(fd_of_out_channel outchan) type seek_command = SEEK_SET diff --git a/otherlibs/win32unix/unix.mli b/otherlibs/win32unix/unix.mli index edf6ddaf0..2a4653009 100644 --- a/otherlibs/win32unix/unix.mli +++ b/otherlibs/win32unix/unix.mli @@ -181,7 +181,8 @@ type open_flag = | O_EXCL (* Fail if existing *) | O_BINARY (* No translation (default) *) | O_TEXT (* Translate as a text file *) - (* The flags to [open]. *) + (* The flags to [openfile], [in_channel_of_descr_gen] and + [out_channel_of_descr_gen]. *) type file_perm = int (* The type of file access rights. *) @@ -190,7 +191,9 @@ external openfile : string -> open_flag list -> file_perm -> file_descr = "unix_open" (* Open the named file with the given flags. Third argument is the permissions to give to the file if it is created. Return - a file descriptor on the named file. *) + a file descriptor on the named file. + The flags [O_NONBLOCK], [O_APPEND], [O_BINARY] and [O_TEXT] + are ignored by [openfile]. *) external close : file_descr -> unit = "unix_close" (* Close a file descriptor. *) val read : file_descr -> string -> int -> int -> int @@ -206,19 +209,26 @@ val write : file_descr -> string -> int -> int -> int (*** Interfacing with the standard input/output library. *) -external in_channel_of_descr : file_descr -> in_channel - = "caml_open_descriptor" - (* Create an input channel reading from the given descriptor. *) -external out_channel_of_descr : file_descr -> out_channel - = "caml_open_descriptor" - (* Create an output channel writing on the given descriptor. *) -external descr_of_in_channel : in_channel -> file_descr = "channel_descriptor" +value in_channel_of_descr : file_descr -> in_channel + (* Create an input channel reading from the given descriptor. + The input channel is opened in text mode. *) +value out_channel_of_descr : file_descr -> out_channel + (* Create an output channel writing on the given descriptor. + The output channel is opened in text mode. *) +value in_channel_of_descr_gen : open_flags list -> file_descr -> in_channel +value out_channel_of_descr_gen : open_flags list -> file_descr -> out_channel + (* Same as [in_channel_of_descr] and [out_channel_of_descr], + except that the first argument (a list of flags) specifies + the opening mode. The following flags are recognized: + [O_TEXT] (open in text mode), [O_BINARY] (open in binary mode), + and [O_APPEND] (all writes go at the end of the file). + Other flags are ignored. *) + +value descr_of_in_channel : in_channel -> file_descr (* Return the descriptor corresponding to an input channel. *) -external descr_of_out_channel : out_channel -> file_descr - = "channel_descriptor" +value descr_of_out_channel : out_channel -> file_descr (* Return the descriptor corresponding to an output channel. *) - (*** Seeking and truncating *) type seek_command = diff --git a/otherlibs/win32unix/unixsupport.c b/otherlibs/win32unix/unixsupport.c index b5aad5700..8a2bb0fc2 100644 --- a/otherlibs/win32unix/unixsupport.c +++ b/otherlibs/win32unix/unixsupport.c @@ -21,6 +21,15 @@ #include <errno.h> #include <winsock.h> +/* Heap-allocation of Windows file handles */ + +value win_alloc_handle(HANDLE h) +{ + value res = alloc(sizeof(HANDLE) / sizeof(value), Abstract_tag); + Handle_val(res) = h; + return res; +} + /* Windows socket errors */ #define EWOULDBLOCK WSAEWOULDBLOCK diff --git a/otherlibs/win32unix/unixsupport.h b/otherlibs/win32unix/unixsupport.h index e8faca3f6..f2b2b2941 100644 --- a/otherlibs/win32unix/unixsupport.h +++ b/otherlibs/win32unix/unixsupport.h @@ -11,6 +11,7 @@ /* $Id$ */ +#include <winbase.h> #include <stdlib.h> /* Include io.h in current dir, which is a copy of the system's io.h, not io.h from ../../byterun */ @@ -18,6 +19,10 @@ #include <direct.h> #include <process.h> +#define Handle_val(v) (*((HANDLE *)(v))) + +extern value win_alloc_handle(HANDLE); + #define Nothing ((value) 0) extern void unix_error (int errcode, char * cmdname, value arg); diff --git a/otherlibs/win32unix/winwait.c b/otherlibs/win32unix/winwait.c index 07bed46f1..c33f356ae 100644 --- a/otherlibs/win32unix/winwait.c +++ b/otherlibs/win32unix/winwait.c @@ -22,11 +22,18 @@ static value alloc_process_status(pid, status) int pid, status; { - value res; - value st = alloc(1, 0); + value res, st; + if ((status & 0xFF) == 0) { + /* Normal termination: lo-byte = 0, hi-byte = child exit code */ + st = alloc(1, 0); + Field(st, 0) = Val_int(status >> 8); + } else { + /* Abnormal termination: lo-byte = term status, hi-byte = 0 */ + st = alloc(1, 1); + Field(st, 0) = Val_int(status & 0xFF); + } Begin_root (st); - Field(st, 0) = Val_int(status); res = alloc_tuple(2); Field(res, 0) = Val_int(pid); Field(res, 1) = st; diff --git a/otherlibs/win32unix/write.c b/otherlibs/win32unix/write.c new file mode 100644 index 000000000..bf79c0e0c --- /dev/null +++ b/otherlibs/win32unix/write.c @@ -0,0 +1,49 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* Automatique. Distributed only by permission. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <errno.h> +#include <string.h> +#include <mlvalues.h> +#include <memory.h> +#include <signals.h> +#include "unixsupport.h" + +value unix_write(value fd, value buf, value vofs, value vlen) /* ML */ +{ + long ofs, len, written; + DWORD numbytes, numwritten; + BOOL ret; + char iobuf[UNIX_BUFFER_SIZE]; + HANDLE h = Handle_val(fd); + + 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; + bcopy(&Byte(buf, ofs), iobuf, numbytes); + enter_blocking_section(); + ret = WriteFile(h, iobuf, numbytes, &numwritten, NULL); + leave_blocking_section(); + if (! ret) { + _dosmaperr(GetLastError()); + uerror("write", Nothing); + } + written += numwritten; + ofs += numwritten; + len -= numwritten; + } + End_roots(); + return Val_long(written); +} |