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

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

1 files changed, 205 insertions, 0 deletions

diff --git a/otherlibs/win32unix/lockf.c b/otherlibs/win32unix/lockf.c
new file mode 100644
index 000000000..84ed2476e
--- /dev/null
+++ b/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;
+}
+