1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
|
/***********************************************************************/
/* */
/* 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 <fail.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)
{
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)
{
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;
}
|
