Meilleure distinction handle/socket. Ajout lockf. Revu rename.

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@4765 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

otherlibs/win32unix/Makefile.nt

@@ -26,8 +26,9 @@ COMPFLAGS=-warn-error A
 WIN_OBJS = accept.obj bind.obj channels.obj close.obj \
   close_on.obj connect.obj createprocess.obj dup.obj dup2.obj errmsg.obj \
   getpeername.obj getpid.obj getsockname.obj gettimeofday.obj \
-  link.obj listen.obj lseek.obj \
-  mkdir.obj open.obj pipe.obj read.obj select.obj sendrecv.obj \
+  link.obj listen.obj lockf.obj lseek.obj \
+  mkdir.obj open.obj pipe.obj read.obj rename.obj \
+  select.obj sendrecv.obj \
   shutdown.obj sleep.obj socket.obj sockopt.obj startup.obj stat.obj \
   system.obj unixsupport.obj windir.obj winwait.obj write.obj
 
@@ -35,7 +36,7 @@ WIN_OBJS = accept.obj bind.obj channels.obj close.obj \
 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 rename.c rmdir.c \
+  getserv.c gmtime.c putenv.c rmdir.c \
   socketaddr.c strofaddr.c time.c unlink.c utimes.c
 
 UNIX_OBJS = $(UNIX_FILES:.c=.obj)
@@ -66,6 +67,8 @@ copy_unix_files:
 io.h: "$(SYSTEM_INCLUDES)\io.h"
 	copy "$(SYSTEM_INCLUDES)\io.h" io.h
 
+$(C_OBJS:.obj=.dobj) $(C_OBJS:.obj=.sobj): unixsupport.h
+
 unix.cma: $(CAML_OBJS)
 	$(CAMLC) -a -linkall -o unix.cma $(CAML_OBJS) \
           -dllib -lunix -cclib -lunix wsock32.lib

otherlibs/win32unix/accept.c

@@ -22,7 +22,7 @@
 CAMLprim value unix_accept(sock)
      value sock;
 {
-  SOCKET sconn = (SOCKET) Handle_val(sock);
+  SOCKET sconn = Socket_val(sock);
   SOCKET snew;
   value fd = Val_unit, adr = Val_unit, res;
   int oldvalue, oldvaluelen, newvalue, retcode;
@@ -52,7 +52,7 @@ CAMLprim value unix_accept(sock)
     uerror("accept", Nothing);
   }
   Begin_roots2 (fd, adr)
-    fd = win_alloc_handle((HANDLE) snew);
+    fd = win_alloc_socket(snew);
     adr = alloc_sockaddr(&addr, addr_len);
     res = alloc_small(2, 0);
     Field(res, 0) = fd;

otherlibs/win32unix/bind.c

@@ -25,7 +25,7 @@ CAMLprim value unix_bind(socket, address)
   socklen_param_type addr_len;
 
   get_sockaddr(address, &addr, &addr_len);
-  ret = bind((SOCKET) Handle_val(socket), &addr.s_gen, addr_len);
+  ret = bind(Socket_val(socket), &addr.s_gen, addr_len);
   if (ret == -1) {
     win32_maperr(WSAGetLastError());
     uerror("bind", Nothing);

otherlibs/win32unix/channels.c

@@ -27,5 +27,5 @@ CAMLprim value win_fd_handle(value handle)
 
 CAMLprim value win_handle_fd(value fd)
 {
-  return win_alloc_handle((HANDLE) _get_osfhandle(Int_val(fd)));
+  return win_alloc_handle_or_socket((HANDLE) _get_osfhandle(Int_val(fd)));
 }

otherlibs/win32unix/close.c

@@ -18,9 +18,16 @@
 
 CAMLprim value unix_close(value fd)
 {
-  if (! CloseHandle(Handle_val(fd))) {
-    win32_maperr(GetLastError());
-    uerror("close", Nothing);
+  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;
 }

otherlibs/win32unix/connect.c

@@ -20,7 +20,7 @@
 CAMLprim value unix_connect(socket, address)
      value socket, address;
 {
-  SOCKET s = (SOCKET) Handle_val(socket);
+  SOCKET s = Socket_val(socket);
   int retcode;
   union sock_addr_union addr;
   socklen_param_type addr_len;

otherlibs/win32unix/dup.c

@@ -19,12 +19,16 @@
 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;
   }
-  return win_alloc_handle(newh);
+  newfd = win_alloc_handle(newh);
+  Descr_kind_val(newfd) = kind;
+  return newfd;
 }
 

otherlibs/win32unix/dup2.c

@@ -28,6 +28,10 @@ CAMLprim value unix_dup2(value fd1, value fd2)
     return -1;
   }
   Handle_val(fd2) = newh;
-  CloseHandle(oldh);
+  if (Descr_kind_val(fd2) == KIND_SOCKET)
+    closesocket((SOCKET) oldh);
+  else
+    CloseHandle(oldh);
+  Descr_kind_val(fd2) = Descr_kind_val(fd1);
   return Val_unit;
 }

otherlibs/win32unix/getpeername.c

@@ -25,7 +25,7 @@ CAMLprim value unix_getpeername(sock)
   socklen_param_type addr_len;
 
   addr_len = sizeof(sock_addr);
-  retcode = getpeername((SOCKET) Handle_val(sock),
+  retcode = getpeername(Socket_val(sock),
                         &addr.s_gen, &addr_len);
   if (retcode == -1) {
     win32_maperr(WSAGetLastError());

otherlibs/win32unix/getsockname.c

@@ -25,7 +25,7 @@ CAMLprim value unix_getsockname(sock)
   socklen_param_type addr_len;
 
   addr_len = sizeof(sock_addr);
-  retcode = getsockname((SOCKET) Handle_val(sock),
+  retcode = getsockname(Socket_val(sock),
                         &addr.s_gen, &addr_len);
   if (retcode == -1) uerror("getsockname", Nothing);
   return alloc_sockaddr(&addr, addr_len);

otherlibs/win32unix/listen.c

@@ -15,12 +15,11 @@
 
 #include <mlvalues.h>
 #include "unixsupport.h"
-#include <winsock.h>
 
 CAMLprim value unix_listen(sock, backlog)
      value sock, backlog;
 {
-  if (listen((SOCKET) Handle_val(sock), Int_val(backlog)) == -1) {
+  if (listen(Socket_val(sock), Int_val(backlog)) == -1) {
     win32_maperr(WSAGetLastError());
     uerror("listen", Nothing);
   }

otherlibs/win32unix/lockf.c

@@ -0,0 +1,205 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           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.  */
+/*  under the terms of the GNU Library General Public License.         */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#include <errno.h>
+#include <fcntl.h>
+#include <mlvalues.h>
+#include "unixsupport.h"
+#include <stdio.h>
+
+/*
+
+Commands for Unix.lockf:
+
+type lock_command =
+
+  | F_ULOCK (* Unlock a region *) 
+
+  | F_LOCK (* Lock a region for writing, and block if already locked *)
+
+  | F_TLOCK (* Lock a region for writing, or fail if already locked *)
+
+  | F_TEST (* Test a region for other process locks *)
+
+  | F_RLOCK (* Lock a region for reading, and block if already locked *)
+
+  | F_TRLOCK  (* Lock a region for reading, or fail if already locked *)
+
+
+val lockf : file_descr -> lock_command -> int -> unitlockf fd cmd size 
+
+puts a lock on a region of the file opened as fd. The region starts at the current
+ read/write position for fd (as set by Unix.lseek), and extends size bytes
+ forward if size is positive, size bytes backwards if size is negative, or 
+ to the end of the file if size is zero. A write lock (set with F_LOCK or
+ F_TLOCK) prevents any other process from acquiring a read or write lock on
+ the region. A read lock (set with F_RLOCK or F_TRLOCK) prevents any other
+ process from acquiring a write lock on the region, but lets other processes
+ acquire read locks on it.
+*/
+
+#ifndef INVALID_SET_FILE_POINTER
+#define INVALID_SET_FILE_POINTER (-1)
+#endif
+
+static void set_file_pointer(HANDLE h, LARGE_INTEGER dest,
+			     PLARGE_INTEGER cur, DWORD method)
+{
+  LONG high = dest.HighPart;
+  DWORD ret = SetFilePointer(h, dest.LowPart, &high, method);
+  if (ret == INVALID_SET_FILE_POINTER) {
+    long err = GetLastError();
+    if (err != NO_ERROR) { win32_maperr(err); uerror("lockf", Nothing); }
+  }
+  if (cur != NULL) { cur->LowPart = ret; cur->HighPart = high; }
+}
+
+CAMLprim value unix_lockf(value fd, value cmd, value span)
+{
+  	int ret;
+	OVERLAPPED overlap;
+	DWORD l_start;
+	DWORD l_len;
+  	HANDLE h;
+  	OSVERSIONINFO VersionInfo;
+	LARGE_INTEGER cur_position;
+	LARGE_INTEGER end_position;
+	LARGE_INTEGER offset_position;
+
+	VersionInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
+	if(GetVersionEx(&VersionInfo) == 0)
+		{
+		return invalid_argument("lockf only supported on WIN32_NT platforms: could not determine current platform.");
+		}
+/* file locking only exists on NT versions */
+	if(VersionInfo.dwPlatformId != VER_PLATFORM_WIN32_NT)
+		{
+		return invalid_argument("lockf only supported on WIN32_NT platforms");
+		}
+
+	h = Handle_val(fd);
+
+	overlap.Offset = 0;
+	overlap.OffsetHigh = 0;
+	overlap.hEvent = 0;
+  	l_len = Long_val(span);
+
+	offset_position.HighPart = 0;
+	cur_position.HighPart = 0;
+	end_position.HighPart = 0;
+	offset_position.LowPart = 0;
+	cur_position.LowPart = 0;
+	end_position.LowPart = 0;
+
+	if(l_len == 0)
+		{
+/* save current pointer */
+		set_file_pointer(h,offset_position,&cur_position,FILE_CURRENT);
+/* set to end and query */
+		set_file_pointer(h,offset_position,&end_position,FILE_END);
+		l_len = end_position.LowPart;
+/* restore previous current pointer */
+		set_file_pointer(h,cur_position,NULL,FILE_BEGIN);
+		}
+	else 
+		{
+  		if (l_len < 0) 
+			{
+			set_file_pointer(h,offset_position,&cur_position,FILE_CURRENT);
+    			l_len = abs(l_len);
+			if(l_len > cur_position.LowPart)
+				{
+        			errno = EINVAL;
+				uerror("lockf", Nothing);
+  				return Val_unit;
+				}
+    			overlap.Offset = cur_position.LowPart - l_len;
+  			} 
+		}
+  switch (Int_val(cmd)) 
+	{
+  	case 0: /* F_ULOCK */
+		if(UnlockFileEx(h, 0, l_len,0,&overlap) == 0)
+			{
+        		errno = EACCES;
+        		ret = -1;
+			}
+    		break;
+  	case 1: /* F_LOCK */
+/* this should block until write lock is obtained */
+		if(LockFileEx(h,LOCKFILE_EXCLUSIVE_LOCK,0,l_len,0,&overlap) == 0)
+			{
+        		errno = EACCES;
+        		ret = -1;
+			}
+    		break;
+  	case 2: /* F_TLOCK */
+/* 
+ * this should return immediately if write lock can-not
+ * be obtained.
+ */
+		if(LockFileEx(h,LOCKFILE_FAIL_IMMEDIATELY | LOCKFILE_EXCLUSIVE_LOCK,0,l_len,0,&overlap) == 0)
+			{
+        		errno = EACCES;
+        		ret = -1;
+			}
+    		break;
+  	case 3: /* F_TEST */
+/*  
+ * 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,l_len,0,&overlap) == 0)
+			{
+        		errno = EACCES;
+        		ret = -1;
+			}
+      		else
+			{
+			UnlockFileEx(h, 0, l_len,0,&overlap);
+        		ret = 0;
+    			}
+    		break;
+  	case 4: /* F_RLOCK */
+/* this should block until read lock is obtained */
+		if(LockFileEx(h,0,0,l_len,0,&overlap) == 0)
+			{
+        		errno = EACCES;
+        		ret = -1;
+			}
+    		break;
+  	case 5: /* F_TRLOCK */
+/* 
+ * this should return immediately if read lock can-not
+ * be obtained.
+ */
+		if(LockFileEx(h,LOCKFILE_FAIL_IMMEDIATELY,0,l_len,0,&overlap) == 0)
+			{
+        		errno = EACCES;
+        		ret = -1;
+			}
+    		break;
+  	default:
+    		errno = EINVAL;
+    		ret = -1;
+  	}
+  if (ret == -1) uerror("lockf", Nothing);
+  return Val_unit;
+}
+

otherlibs/win32unix/read.c

@@ -22,19 +22,32 @@
 CAMLprim value unix_read(value fd, value buf, value ofs, value len)
 {
   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) {
-      win32_maperr(GetLastError());
-      uerror("read", Nothing);
+    if (Descr_kind_val(fd) == KIND_SOCKET) {
+      int ret;
+      SOCKET s = Socket_val(fd);
+      enter_blocking_section();
+      ret = recv(s, iobuf, numbytes, 0);
+      leave_blocking_section();
+      if (ret == SOCKET_ERROR) {
+	win32_maperr(WSAGetLastError());
+	uerror("read", Nothing);
+      }
+      numread = ret;
+    } else {
+      BOOL ret;
+      HANDLE h = Handle_val(fd);
+      enter_blocking_section();
+      ret = ReadFile(h, iobuf, numbytes, &numread, NULL);
+      leave_blocking_section();
+      if (! ret) {
+	win32_maperr(GetLastError());
+	uerror("read", Nothing);
+      }
     }
     memmove (&Byte(buf, Long_val(ofs)), iobuf, numread);
   End_roots();

otherlibs/win32unix/rename.c

@@ -0,0 +1,29 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           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)
+{
+  if (MoveFileEx(String_val(path1), String_val(path2),
+		 MOVEFILE_REPLACE_EXISTING | MOVEFILE_WRITE_THROUGH |
+		 MOVEFILE_COPY_ALLOWED) == 0) {
+    win32_maperr(GetLastError());
+    uerror("rename", path1);
+  }	
+  return Val_unit;
+}

otherlibs/win32unix/select.c

@@ -18,14 +18,13 @@
 #include <memory.h>
 #include <signals.h>
 #include "unixsupport.h"
-#include <winsock.h>
 
 static void fdlist_to_fdset(value fdlist, fd_set *fdset)
 {
   value l;
   FD_ZERO(fdset);
   for (l = fdlist; l != Val_int(0); l = Field(l, 1)) {
-    FD_SET((SOCKET) Handle_val(Field(l, 0)), fdset);
+    FD_SET(Socket_val(Field(l, 0)), fdset);
   }
 }
 
@@ -35,7 +34,7 @@ static value fdset_to_fdlist(value fdlist, fd_set *fdset)
   Begin_roots2(fdlist, res)
     for (/*nothing*/; fdlist != Val_int(0); fdlist = Field(fdlist, 1)) {
       value s = Field(fdlist, 0);
-      if (FD_ISSET((SOCKET) Handle_val(s), fdset)) {
+      if (FD_ISSET(Socket_val(s), fdset)) {
         value newres = alloc_small(2, 0);
         Field(newres, 0) = s;
         Field(newres, 1) = res;

otherlibs/win32unix/sendrecv.c

@@ -33,7 +33,7 @@ CAMLprim value unix_recv(value sock, value buff, value ofs, value len, value fla
     numbytes = Long_val(len);
     if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
     enter_blocking_section();
-    ret = recv((SOCKET) Handle_val(sock), iobuf, (int) numbytes,
+    ret = recv(Socket_val(sock), iobuf, (int) numbytes,
                convert_flag_list(flags, msg_flag_table));
     leave_blocking_section();
     if (ret == -1) {
@@ -60,7 +60,7 @@ CAMLprim value unix_recvfrom(value sock, value buff, value ofs, value len, value
     if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
     addr_len = sizeof(sock_addr);
     enter_blocking_section();
-    ret = recvfrom((SOCKET) Handle_val(sock),
+    ret = recvfrom(Socket_val(sock),
                    iobuf, (int) numbytes,
                    convert_flag_list(flags, msg_flag_table),
                    &addr.s_gen, &addr_len);
@@ -88,7 +88,7 @@ CAMLprim value unix_send(value sock, value buff, value ofs, value len, value fla
   if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
   memmove (iobuf, &Byte(buff, Long_val(ofs)), numbytes);
   enter_blocking_section();
-  ret = send((SOCKET) Handle_val(sock), iobuf, (int) numbytes,
+  ret = send(Socket_val(sock), iobuf, (int) numbytes,
              convert_flag_list(flags, msg_flag_table));
   leave_blocking_section();
   if (ret == -1) {
@@ -111,7 +111,7 @@ value unix_sendto_native(value sock, value buff, value ofs, value len, value fla
   if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
   memmove (iobuf, &Byte(buff, Long_val(ofs)), numbytes);
   enter_blocking_section();
-  ret = sendto((SOCKET) Handle_val(sock),
+  ret = sendto(Socket_val(sock),
                iobuf, (int) numbytes,
                convert_flag_list(flags, msg_flag_table),
                &addr.s_gen, addr_len);

otherlibs/win32unix/shutdown.c

@@ -15,7 +15,6 @@
 
 #include <mlvalues.h>
 #include "unixsupport.h"
-#include <winsock.h>
 
 static int shutdown_command_table[] = {
   0, 1, 2
@@ -24,7 +23,7 @@ static int shutdown_command_table[] = {
 CAMLprim value unix_shutdown(sock, cmd)
      value sock, cmd;
 {
-  if (shutdown((SOCKET) Handle_val(sock),
+  if (shutdown(Socket_val(sock),
                shutdown_command_table[Int_val(cmd)]) == -1) {
     win32_maperr(WSAGetLastError());
     uerror("shutdown", Nothing);

otherlibs/win32unix/socket.c

@@ -15,8 +15,6 @@
 
 #include <mlvalues.h>
 #include "unixsupport.h"
-#include <sys/types.h>
-#include <winsock.h>
 
 int socket_domain_table[] = {
   PF_UNIX, PF_INET
@@ -53,5 +51,5 @@ CAMLprim value unix_socket(domain, type, proto)
     win32_maperr(WSAGetLastError());
     uerror("socket", Nothing);
   }
-  return win_alloc_handle((HANDLE) s);
+  return win_alloc_socket(s);
 }

otherlibs/win32unix/socketaddr.h

@@ -14,8 +14,6 @@
 /* $Id$ */
 
 #include <misc.h>
-#include <sys/types.h>
-#include <winsock.h>
 
 union sock_addr_union {
   struct sockaddr s_gen;

otherlibs/win32unix/sockopt.c

@@ -15,8 +15,6 @@
 
 #include <mlvalues.h>
 #include "unixsupport.h"
-#include <winsock.h>
-#include <sys/types.h>
 
 static int sockopt_bool[] = {
   SO_DEBUG, SO_BROADCAST, SO_REUSEADDR, SO_KEEPALIVE,
@@ -36,7 +34,7 @@ CAMLprim value getsockopt_int(int *sockopt, value socket,
   int optsize;
 
   optsize = sizeof(optval);
-  if (getsockopt((SOCKET) Handle_val(socket),
+  if (getsockopt(Socket_val(socket),
                  level, sockopt[Int_val(option)],
 		 (void *) &optval, &optsize) == -1)
     uerror("getsockopt", Nothing);
@@ -47,7 +45,7 @@ CAMLprim value setsockopt_int(int *sockopt, value socket, int level,
                               value option, value status)
 {
   int optval = Int_val(status);
-  if (setsockopt((SOCKET) Handle_val(socket),
+  if (setsockopt(Socket_val(socket),
                  level, sockopt[Int_val(option)],
 		 (void *) &optval, sizeof(optval)) == -1)
     uerror("setsockopt", Nothing);
@@ -80,7 +78,7 @@ CAMLprim value getsockopt_optint(int *sockopt, value socket,
   value res = Val_int(0);			/* None */
 
   optsize = sizeof(optval);
-  if (getsockopt((SOCKET) Handle_val(socket),
+  if (getsockopt(Socket_val(socket),
                  level, sockopt[Int_val(option)],
 		 (void *) &optval, &optsize) == -1)
     uerror("getsockopt_optint", Nothing);
@@ -99,7 +97,7 @@ CAMLprim value setsockopt_optint(int *sockopt, value socket, int level,
   optval.l_onoff = Is_block (status);
   if (optval.l_onoff)
     optval.l_linger = Int_val (Field (status, 0));
-  if (setsockopt((SOCKET) Handle_val(socket),
+  if (setsockopt(Socket_val(socket),
                  level, sockopt[Int_val(option)],
 		 (void *) &optval, sizeof(optval)) == -1)
     uerror("setsockopt_optint", Nothing);
@@ -123,7 +121,7 @@ CAMLprim value getsockopt_float(int *sockopt, value socket,
   int optsize;
 
   optsize = sizeof(tv);
-  if (getsockopt((SOCKET) Handle_val(socket),
+  if (getsockopt(Socket_val(socket),
                  level, sockopt[Int_val(option)],
 		 (void *) &tv, &optsize) == -1)
     uerror("getsockopt_float", Nothing);
@@ -139,7 +137,7 @@ CAMLprim value setsockopt_float(int *sockopt, value socket, int level,
   tv_f = Double_val(status);
   tv.tv_sec = (int)tv_f;
   tv.tv_usec = (int) (1e6 * (tv_f - tv.tv_sec));
-  if (setsockopt((SOCKET) Handle_val(socket),
+  if (setsockopt(Socket_val(socket),
                  level, sockopt[Int_val(option)],
 		 (void *) &tv, sizeof(tv)) == -1)
     uerror("setsockopt_float", Nothing);

otherlibs/win32unix/startup.c

@@ -15,7 +15,7 @@
 #include <fcntl.h>
 #include <stdlib.h>
 #include <mlvalues.h>
-#include <winsock.h>
+#include "unixsupport.h"
 
 value val_process_id;
 
@@ -48,5 +48,5 @@ static int std_handles[3] = {
 
 CAMLprim value win_stdhandle(value nhandle)
 {
-  return win_alloc_handle(GetStdHandle(std_handles[Int_val(nhandle)]));
+  return win_alloc_handle_or_socket(GetStdHandle(std_handles[Int_val(nhandle)]));
 }

otherlibs/win32unix/unix.ml

@@ -376,7 +376,7 @@ type lock_command =
   | F_RLOCK
   | F_TRLOCK
 
-let lockf fd cmd exten = invalid_arg "Unix.lockf not implemented"
+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"

otherlibs/win32unix/unixsupport.c

@@ -22,7 +22,6 @@
 #include "unixsupport.h"
 #include "cst2constr.h"
 #include <errno.h>
-#include <winsock.h>
 
 /* Heap-allocation of Windows file handles */
 
@@ -49,9 +48,27 @@ static struct custom_operations win_handle_ops = {
 
 value win_alloc_handle(HANDLE h)
 {
-  value res = 
-    alloc_custom(&win_handle_ops, sizeof(HANDLE), 0, 1);
+  value res = alloc_custom(&win_handle_ops, sizeof(struct filedescr), 0, 1);
   Handle_val(res) = h;
+  Descr_kind_val(res) = KIND_HANDLE;
+  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;
+  return res;
+}
+
+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;
 }
 

otherlibs/win32unix/unixsupport.h

@@ -21,10 +21,24 @@
 #include "io.h"
 #include <direct.h>
 #include <process.h>
+#include <sys/types.h>
+#include <winsock.h>
 
-#define Handle_val(v) (*((HANDLE *) Data_custom_val(v)))
+struct filedescr {
+  union {
+    HANDLE handle;
+    SOCKET socket;
+  } fd;
+  enum { KIND_HANDLE, KIND_SOCKET } kind;
+};
 
+#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)
+
+extern value win_alloc_handle_or_socket(HANDLE);
 extern value win_alloc_handle(HANDLE);
+extern value win_alloc_socket(SOCKET);
 
 #define Nothing ((value) 0)
 

otherlibs/win32unix/write.c

@@ -24,9 +24,7 @@ CAMLprim value unix_write(value fd, value buf, value vofs, value vlen)
 {
   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);
@@ -35,12 +33,27 @@ CAMLprim value unix_write(value fd, value buf, value vofs, value vlen)
     while (len > 0) {
       numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len;
       memmove (iobuf, &Byte(buf, ofs), numbytes);
-      enter_blocking_section();
-      ret = WriteFile(h, iobuf, numbytes, &numwritten, NULL);
-      leave_blocking_section();
-      if (! ret) {
-        win32_maperr(GetLastError());
-        uerror("write", Nothing);
+      if (Descr_kind_val(fd) == KIND_SOCKET) {
+	int ret;
+	SOCKET s = Socket_val(fd);
+	enter_blocking_section();
+	ret = send(s, iobuf, numbytes, 0);
+	leave_blocking_section();
+	if (ret == SOCKET_ERROR) {
+	  win32_maperr(WSAGetLastError());
+	  uerror("write", Nothing);
+	}
+	numwritten = ret;
+      } else {
+	BOOL ret;
+	HANDLE h = Handle_val(fd);
+	enter_blocking_section();
+	ret = WriteFile(h, iobuf, numbytes, &numwritten, NULL);
+	leave_blocking_section();
+	if (! ret) {
+	  win32_maperr(GetLastError());
+	  uerror("write", Nothing);
+	}
       }
       written += numwritten;
       ofs += numwritten;