1 /**************************************************************************/
2 /* */
3 /* OCaml */
4 /* */
5 /* Contributed by Tracy Camp, PolyServe Inc., <campt@polyserve.com> */
6 /* Further improvements by Reed Wilson */
7 /* */
8 /* Copyright 2002 Institut National de Recherche en Informatique et */
9 /* en Automatique. */
10 /* */
11 /* All rights reserved. This file is distributed under the terms of */
12 /* the GNU Lesser General Public License version 2.1, with the */
13 /* special exception on linking described in the file LICENSE. */
14 /* */
15 /**************************************************************************/
16
17 #include <errno.h>
18 #include <fcntl.h>
19 #include <caml/mlvalues.h>
20 #include <caml/memory.h>
21 #include <caml/fail.h>
22 #include "unixsupport.h"
23 #include <stdio.h>
24 #include <caml/signals.h>
25
26 #ifndef INVALID_SET_FILE_POINTER
27 #define INVALID_SET_FILE_POINTER (-1)
28 #endif
29
30 /* Sets handle h to a position based on gohere */
31 /* output, if set, is changed to the new location */
32
set_file_pointer(HANDLE h,LARGE_INTEGER gohere,PLARGE_INTEGER output,DWORD method)33 static void set_file_pointer(HANDLE h, LARGE_INTEGER gohere,
34 PLARGE_INTEGER output, DWORD method)
35 {
36 LONG high = gohere.HighPart;
37 DWORD ret = SetFilePointer(h, gohere.LowPart, &high, method);
38 if(ret == INVALID_SET_FILE_POINTER) {
39 DWORD err = GetLastError();
40 if(err != NO_ERROR) {
41 win32_maperr(err);
42 uerror("lockf", Nothing);
43 }
44 }
45 if(output != NULL) {
46 output->LowPart = ret;
47 output->HighPart = high;
48 }
49 }
50
unix_lockf(value fd,value cmd,value span)51 CAMLprim value unix_lockf(value fd, value cmd, value span)
52 {
53 CAMLparam3(fd, cmd, span);
54 OVERLAPPED overlap;
55 intnat l_len;
56 HANDLE h;
57 OSVERSIONINFO version;
58 LARGE_INTEGER cur_position;
59 LARGE_INTEGER beg_position;
60 LARGE_INTEGER lock_len;
61 LARGE_INTEGER zero;
62 DWORD err = NO_ERROR;
63
64 version.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
65 if(GetVersionEx(&version) == 0) {
66 caml_invalid_argument("lockf only supported on WIN32_NT platforms:"
67 " could not determine current platform.");
68 }
69 if(version.dwPlatformId != VER_PLATFORM_WIN32_NT) {
70 caml_invalid_argument("lockf only supported on WIN32_NT platforms");
71 }
72
73 h = Handle_val(fd);
74
75 l_len = Long_val(span);
76
77 /* No matter what, we need the current position in the file */
78 zero.HighPart = zero.LowPart = 0;
79 set_file_pointer(h, zero, &cur_position, FILE_CURRENT);
80
81 /* All unused fields must be set to zero */
82 memset(&overlap, 0, sizeof(overlap));
83
84 if(l_len == 0) {
85 /* Lock from cur to infinity */
86 lock_len.QuadPart = -1;
87 overlap.OffsetHigh = cur_position.HighPart;
88 overlap.Offset = cur_position.LowPart ;
89 }
90 else if(l_len > 0) {
91 /* Positive file offset */
92 lock_len.QuadPart = l_len;
93 overlap.OffsetHigh = cur_position.HighPart;
94 overlap.Offset = cur_position.LowPart ;
95 }
96 else {
97 /* Negative file offset */
98 lock_len.QuadPart = - l_len;
99 if (lock_len.QuadPart > cur_position.QuadPart) {
100 errno = EINVAL;
101 uerror("lockf", Nothing);
102 }
103 beg_position.QuadPart = cur_position.QuadPart - lock_len.QuadPart;
104 overlap.OffsetHigh = beg_position.HighPart;
105 overlap.Offset = beg_position.LowPart ;
106 }
107
108 switch(Int_val(cmd)) {
109 case 0: /* F_ULOCK - unlock */
110 if (! UnlockFileEx(h, 0,
111 lock_len.LowPart, lock_len.HighPart, &overlap))
112 err = GetLastError();
113 break;
114 case 1: /* F_LOCK - blocking write lock */
115 caml_enter_blocking_section();
116 if (! LockFileEx(h, LOCKFILE_EXCLUSIVE_LOCK, 0,
117 lock_len.LowPart, lock_len.HighPart, &overlap))
118 err = GetLastError();
119 caml_leave_blocking_section();
120 break;
121 case 2: /* F_TLOCK - non-blocking write lock */
122 if (! LockFileEx(h, LOCKFILE_FAIL_IMMEDIATELY | LOCKFILE_EXCLUSIVE_LOCK, 0,
123 lock_len.LowPart, lock_len.HighPart, &overlap))
124 err = GetLastError();
125 break;
126 case 3: /* F_TEST - check whether a write lock can be obtained */
127 /* I'm doing this by aquiring an immediate write
128 * lock and then releasing it. It is not clear that
129 * this behavior matches anything in particular, but
130 * it is not clear the nature of the lock test performed
131 * by ocaml (unix) currently. */
132 if (LockFileEx(h, LOCKFILE_FAIL_IMMEDIATELY | LOCKFILE_EXCLUSIVE_LOCK, 0,
133 lock_len.LowPart, lock_len.HighPart, &overlap)) {
134 UnlockFileEx(h, 0, lock_len.LowPart, lock_len.HighPart, &overlap);
135 } else {
136 err = GetLastError();
137 }
138 break;
139 case 4: /* F_RLOCK - blocking read lock */
140 caml_enter_blocking_section();
141 if (! LockFileEx(h, 0, 0,
142 lock_len.LowPart, lock_len.HighPart, &overlap))
143 err = GetLastError();
144 caml_leave_blocking_section();
145 break;
146 case 5: /* F_TRLOCK - non-blocking read lock */
147 if (! LockFileEx(h, LOCKFILE_FAIL_IMMEDIATELY, 0,
148 lock_len.LowPart, lock_len.HighPart, &overlap))
149 err = GetLastError();
150 break;
151 default:
152 errno = EINVAL;
153 uerror("lockf", Nothing);
154 }
155 if (err != NO_ERROR) {
156 win32_maperr(err);
157 uerror("lockf", Nothing);
158 }
159 CAMLreturn(Val_unit);
160 }
161