CAMLprim value win_check_connection (value socket, value kind, value idx) {
CAMLparam3 (socket, kind, idx);
WSANETWORKEVENTS evs;
int res, err, i = Long_val(idx);
D(printf("Check connection... %d\n", i));
if (WSAEnumNetworkEvents(Socket_val(socket), NULL, &evs)) {
win32_maperr(WSAGetLastError ());
uerror("WSAEnumNetworkEvents", Nothing);
}
if (WSAEventSelect(Socket_val(socket), NULL, 0) == SOCKET_ERROR) {
win32_maperr(WSAGetLastError ());
uerror("WSAEventSelect", Nothing);
}
if (!CloseHandle(events[i])) {
win32_maperr(GetLastError ());
uerror("CloseHandle", Nothing);
}
err =
evs.iErrorCode[(Long_val(kind) == 0) ? FD_CONNECT_BIT : FD_ACCEPT_BIT];
D(printf("Check connection: %ld, err %d\n", evs.lNetworkEvents, err));
if (err != 0) {
win32_maperr(err);
uerror("check_connection", Nothing);
}
CAMLreturn (Val_unit);
}
CAMLprim value onlyWin32_waitpids_ml(value ncount_v, value pid_reqs_v)
{
int flags,i;
DWORD status, retcode;
DWORD err = 0;
int ncount = Int_val(ncount_v);
HANDLE* pid_reqs;
HANDLE pid_req;
pid_reqs = malloc(sizeof(HANDLE) * ncount);
for(i=0; i < ncount; i++){
pid_reqs[i] = (HANDLE) Long_val(Field(pid_reqs_v,i));
}
enter_blocking_section();
retcode = WaitForMultipleObjects(ncount, pid_reqs, FALSE,INFINITE);
if (retcode == WAIT_FAILED) err = GetLastError();
leave_blocking_section();
if (err) {
free(pid_reqs);
win32_maperr(err);
uerror("waitpids", Nothing);
}
pid_req = pid_reqs[retcode - WAIT_OBJECT_0];
free(pid_reqs);
if (! GetExitCodeProcess(pid_req, &status)) {
win32_maperr(GetLastError());
uerror("waitpids", Nothing);
}
if (status == STILL_ACTIVE)
return alloc_process_status((HANDLE) 0, 0);
else {
CloseHandle(pid_req);
return alloc_process_status(pid_req, status);
}
}
CAMLprim value win_waitpid(value vflags, value vpid_req)
{
int flags;
DWORD status, retcode;
HANDLE pid_req = (HANDLE) Long_val(vpid_req);
DWORD err = 0;
flags = convert_flag_list(vflags, wait_flag_table);
if ((flags & CAML_WNOHANG) == 0) {
enter_blocking_section();
retcode = WaitForSingleObject(pid_req, INFINITE);
if (retcode == WAIT_FAILED) err = GetLastError();
leave_blocking_section();
if (err) {
win32_maperr(err);
uerror("waitpid", Nothing);
}
}
if (! GetExitCodeProcess(pid_req, &status)) {
win32_maperr(GetLastError());
uerror("waitpid", Nothing);
}
if (status == STILL_ACTIVE)
return alloc_process_status((HANDLE) 0, 0);
else {
CloseHandle(pid_req);
return alloc_process_status(pid_req, status);
}
}
CAMLprim value w_create_process_native
(value prog, value wprog, value wargs, value fd1, value fd2, value fd3)
{
int res, flags;
PROCESS_INFORMATION pi;
STARTUPINFOW si;
wchar_t fullname [MAX_PATH];
HANDLE h;
CAMLparam5(wprog, wargs, fd1, fd2, fd3);
res = SearchPathW (NULL, (LPCWSTR) String_val(wprog), L".exe",
MAX_PATH, fullname, NULL);
if (res == 0) {
win32_maperr (GetLastError ());
uerror("create_process", prog);
}
ZeroMemory(&si, sizeof(STARTUPINFO));
si.cb = sizeof(STARTUPINFO);
si.dwFlags = STARTF_USESTDHANDLES;
si.hStdInput = Handle_val(fd1);
si.hStdOutput = Handle_val(fd2);
si.hStdError = Handle_val(fd3);
flags = GetPriorityClass (GetCurrentProcess ());
/*
h = CreateFile ("CONOUT$", GENERIC_WRITE, FILE_SHARE_WRITE, NULL,
OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
if (h != INVALID_HANDLE_VALUE)
CloseHandle (h);
else {
flags |= CREATE_NEW_CONSOLE;
// si.dwFlags |= STARTF_USESHOWWINDOW;
// si.wShowWindow = SW_MINIMIZE;
}
*/
res = CreateProcessW (fullname, (LPWSTR) String_val(wargs),
NULL, NULL, TRUE, flags,
NULL, NULL, &si, &pi);
if (res == 0) {
win32_maperr (GetLastError ());
uerror("create_process", prog);
}
CloseHandle (pi.hThread);
CAMLreturn (Val_long (pi.hProcess));
}
CAMLprim value unix_close(value fd)
{
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;
}
CAMLprim value win_findfirstw(value name)
{
HANDLE h;
WIN32_FIND_DATAW fileinfo;
CAMLparam1(name);
CAMLlocal3(v, valname, valh);
h = FindFirstFileW((LPCWSTR) String_val(name),&fileinfo);
if (h == INVALID_HANDLE_VALUE) {
DWORD err = GetLastError();
if ((err == ERROR_NO_MORE_FILES) || (err == ERROR_FILE_NOT_FOUND))
raise_end_of_file();
else {
win32_maperr(err);
uerror("opendir", Nothing);
}
}
valname = copy_wstring(fileinfo.cFileName);
valh = win_alloc_handle(h);
v = alloc_small(2, 0);
Field(v,0) = valname;
Field(v,1) = valh;
CAMLreturn (v);
}
/* Free select data */
void select_data_free (LPSELECTDATA lpSelectData)
{
DWORD i;
#ifdef DBUG
dbug_print("Freeing data of %x", lpSelectData);
#endif
/* Free APC related data, if they exists */
if (lpSelectData->lpWorker != NULL)
{
worker_job_finish(lpSelectData->lpWorker);
lpSelectData->lpWorker = NULL;
};
/* Make sure results/queries cannot be accessed */
lpSelectData->nResultsCount = 0;
lpSelectData->nQueriesCount = 0;
if (!HeapLock(GetProcessHeap()))
{
win32_maperr(GetLastError());
uerror("select_data_free", Nothing);
};
HeapFree(GetProcessHeap(), 0, lpSelectData);
HeapUnlock(GetProcessHeap());
}
/* Create data associated with a select operation */
LPSELECTDATA select_data_new (LPSELECTDATA lpSelectData, SELECTTYPE EType)
{
/* Allocate the data structure */
LPSELECTDATA res;
DWORD i;
if (!HeapLock(GetProcessHeap()))
{
win32_maperr(GetLastError());
uerror("select", Nothing);
}
res = (LPSELECTDATA)HeapAlloc(GetProcessHeap(), 0, sizeof(SELECTDATA));
HeapUnlock(GetProcessHeap());
/* Init common data */
list_init((LPLIST)res);
list_next_set((LPLIST)res, (LPLIST)lpSelectData);
res->EType = EType;
res->nResultsCount = 0;
/* Data following are dedicated to APC like call, they
will be initialized if required. For now they are set to
invalid values.
*/
res->funcWorker = NULL;
res->nQueriesCount = 0;
res->EState = SELECT_STATE_NONE;
res->nError = 0;
res->lpWorker = NULL;
return res;
}
CAMLprim value unix_recv(value sock, value buff, value ofs, value len,
value flags)
{
SOCKET s = Socket_val(sock);
int flg = convert_flag_list(flags, msg_flag_table);
int ret;
intnat numbytes;
char iobuf[UNIX_BUFFER_SIZE];
DWORD err = 0;
Begin_root (buff);
numbytes = Long_val(len);
if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
enter_blocking_section();
ret = recv(s, iobuf, (int) numbytes, flg);
if (ret == -1) err = WSAGetLastError();
leave_blocking_section();
if (ret == -1) {
win32_maperr(err);
uerror("recv", Nothing);
}
memmove (&Byte(buff, Long_val(ofs)), iobuf, ret);
End_roots();
return Val_int(ret);
}
value unix_sendto_native(value sock, value buff, value ofs, value len, value flags, value dest)
{
SOCKET s = Socket_val(sock);
int flg = convert_flag_list(flags, msg_flag_table);
int ret;
intnat numbytes;
char iobuf[UNIX_BUFFER_SIZE];
union sock_addr_union addr;
socklen_param_type addr_len;
DWORD err = 0;
get_sockaddr(dest, &addr, &addr_len);
numbytes = Long_val(len);
if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
memmove (iobuf, &Byte(buff, Long_val(ofs)), numbytes);
enter_blocking_section();
ret = sendto(s, iobuf, (int) numbytes, flg, &addr.s_gen, addr_len);
if (ret == -1) err = WSAGetLastError();
leave_blocking_section();
if (ret == -1) {
win32_maperr(err);
uerror("sendto", Nothing);
}
return Val_int(ret);
}
CAMLprim value lwt_unix_read(value fd, value buf, value vofs, value vlen)
{
intnat ofs, len, written;
DWORD numbytes, numwritten;
DWORD err = 0;
Begin_root (buf);
ofs = Long_val(vofs);
len = Long_val(vlen);
written = 0;
if (len > 0) {
numbytes = len;
if (Descr_kind_val(fd) == KIND_SOCKET) {
int ret;
SOCKET s = Socket_val(fd);
ret = recv(s, &Byte(buf, ofs), numbytes, 0);
if (ret == SOCKET_ERROR) err = WSAGetLastError();
numwritten = ret;
} else {
HANDLE h = Handle_val(fd);
if (! ReadFile(h, &Byte(buf, ofs), numbytes, &numwritten, NULL))
err = GetLastError();
}
if (err) {
win32_maperr(err);
uerror("write", Nothing);
}
written = numwritten;
}
End_roots();
return Val_long(written);
}
CAMLprim value
stub_ba_send(value fd, value val_buf, value val_ofs, value val_len)
{
CAMLparam4(fd, val_buf, val_ofs, val_len);
int ret = 0;
#ifdef WIN32
char *data = (char*)Caml_ba_data_val(val_buf) + Long_val(val_ofs);
size_t c_len = Int_val(val_len);
SOCKET s = Socket_val(fd);
DWORD err = 0;
caml_release_runtime_system();
ret = send(s, data, c_len, 0);
if (ret == SOCKET_ERROR) err = WSAGetLastError();
caml_acquire_runtime_system();
if (err) {
win32_maperr(err);
uerror("read", Nothing);
}
#else
caml_failwith("AF_HYPERV only available on Windows");
#endif
CAMLreturn(Val_int(ret));
}
value onlyWin32_getFileInformationByHandle_ml(value handle_v)
{
HANDLE handle = (HANDLE)handle_v;
BY_HANDLE_FILE_INFORMATION fileInfo;
CAMLparam0 ();
CAMLlocal1 (v);
ULARGE_INTEGER size, index;
if( !GetFileInformationByHandle(handle, &fileInfo) ){
DWORD err = GetLastError();
win32_maperr(err);
uerror("GetFileInformationByHandle", Nothing);
}
size.HighPart = fileInfo.nFileSizeHigh;
size.LowPart = fileInfo.nFileSizeLow;
index.HighPart = fileInfo.nFileIndexHigh;
index.LowPart = fileInfo.nFileIndexLow;
v = caml_alloc (8, 0);
Store_field(v,0, Val_int(fileInfo.dwFileAttributes));
Store_field(v, 1,
caml_copy_double(FileTime_to_POSIX(fileInfo.ftCreationTime)));
Store_field(v, 2,
caml_copy_double(FileTime_to_POSIX(fileInfo.ftLastAccessTime)));
Store_field(v, 3,
caml_copy_double(FileTime_to_POSIX(fileInfo.ftLastWriteTime)));
Store_field(v, 4, Val_int(fileInfo.dwVolumeSerialNumber));
Store_field(v, 5, caml_copy_int64(size.QuadPart));
Store_field(v, 6, Val_int(fileInfo.nNumberOfLinks));
Store_field(v, 7, caml_copy_int64(index.QuadPart));
CAMLreturn (v);
}
CAMLprim value win_findfirst(value name)
{
HANDLE h;
value v;
WIN32_FIND_DATA fileinfo;
value valname = Val_unit;
value valh = Val_unit;
caml_unix_check_path(name, "opendir");
Begin_roots2 (valname,valh);
h = FindFirstFile(String_val(name),&fileinfo);
if (h == INVALID_HANDLE_VALUE) {
DWORD err = GetLastError();
if (err == ERROR_NO_MORE_FILES)
raise_end_of_file();
else {
win32_maperr(err);
uerror("opendir", Nothing);
}
}
valname = copy_string(fileinfo.cFileName);
valh = win_alloc_handle(h);
v = alloc_small(2, 0);
Field(v,0) = valname;
Field(v,1) = valh;
End_roots();
return v;
}
CAMLprim value unix_recvfrom(value sock, value buff, value ofs, value len, value flags)
{
SOCKET s = Socket_val(sock);
int flg = convert_flag_list(flags, msg_flag_table);
int ret;
intnat numbytes;
char iobuf[UNIX_BUFFER_SIZE];
value res;
value adr = Val_unit;
union sock_addr_union addr;
socklen_param_type addr_len;
DWORD err = 0;
Begin_roots2 (buff, adr);
numbytes = Long_val(len);
if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
addr_len = sizeof(sock_addr);
enter_blocking_section();
ret = recvfrom(s, iobuf, (int) numbytes, flg, &addr.s_gen, &addr_len);
if (ret == -1) err = WSAGetLastError();
leave_blocking_section();
if (ret == -1) {
win32_maperr(err);
uerror("recvfrom", Nothing);
}
memmove (&Byte(buff, Long_val(ofs)), iobuf, ret);
adr = alloc_sockaddr(&addr, addr_len, -1);
res = alloc_small(2, 0);
Field(res, 0) = Val_int(ret);
Field(res, 1) = adr;
End_roots();
return res;
}
CAMLprim value unix_read(value fd, value buf, value ofs, value vlen)
{
intnat len;
DWORD numbytes, numread;
char iobuf[UNIX_BUFFER_SIZE];
DWORD err = 0;
Begin_root (buf);
len = Long_val(vlen);
numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len;
if (Descr_kind_val(fd) == KIND_SOCKET) {
int ret;
SOCKET s = Socket_val(fd);
enter_blocking_section();
ret = recv(s, iobuf, numbytes, 0);
if (ret == SOCKET_ERROR) err = WSAGetLastError();
leave_blocking_section();
numread = ret;
} else {
HANDLE h = Handle_val(fd);
enter_blocking_section();
if (! ReadFile(h, iobuf, numbytes, &numread, NULL))
err = GetLastError();
leave_blocking_section();
}
if (err) {
win32_maperr(err);
uerror("read", Nothing);
}
memmove (&Byte(buf, Long_val(ofs)), iobuf, numread);
End_roots();
return Val_int(numread);
}
static void overlapped_action(long action, long id,
HANDLE fd, char *buf, long len) {
BOOL res;
long err;
completionData * d = GlobalAlloc(GPTR, sizeof(completionData));
if (d == NULL) {
errno = ENOMEM;
uerror(action_name[action], Nothing);
}
d->id = id;
d->action = action;
D(printf("Starting %s: id %ld, len %ld\n", action_name[action], id, len));
res =
(action == READ_OVERLAPPED)?
ReadFileEx(fd, buf, len, &(d->overlapped), overlapped_completion):
WriteFileEx(fd, buf, len, &(d->overlapped), overlapped_completion);
if (!res) {
err = GetLastError ();
if (err != ERROR_IO_PENDING) {
win32_maperr (err);
D(printf("Action %s failed: id %ld -> err %d (errCode %ld)\n",
action_name[action], id, errno, err));
uerror("ReadFileEx", Nothing);
}
}
}
static int convert_time(FILETIME* time, __time64_t* result, __time64_t def)
{
SYSTEMTIME sys;
FILETIME local;
if (time->dwLowDateTime || time->dwHighDateTime) {
if (!FileTimeToLocalFileTime(time, &local) ||
!FileTimeToSystemTime(&local, &sys))
{
win32_maperr(GetLastError());
return 0;
}
else
{
struct tm stamp = {sys.wSecond, sys.wMinute, sys.wHour,
sys.wDay, sys.wMonth - 1, sys.wYear - 1900,
0, 0, 0};
*result = _mktime64(&stamp);
}
}
else {
*result = def;
}
return 1;
}
LPWORKER worker_new (void)
{
LPWORKER lpWorker = NULL;
if (!HeapLock(hWorkerHeap))
{
win32_maperr(GetLastError());
uerror("worker_new", Nothing);
};
lpWorker = (LPWORKER)HeapAlloc(hWorkerHeap, 0, sizeof(WORKER));
HeapUnlock(hWorkerHeap);
list_init((LPLIST)lpWorker);
lpWorker->hJobStarted = CreateEvent(NULL, TRUE, FALSE, NULL);
lpWorker->hJobStop = CreateEvent(NULL, TRUE, FALSE, NULL);
lpWorker->hJobDone = CreateEvent(NULL, TRUE, FALSE, NULL);
lpWorker->lpJobUserData = NULL;
lpWorker->hWorkerReady = CreateEvent(NULL, FALSE, FALSE, NULL);
lpWorker->hCommandReady = CreateEvent(NULL, FALSE, FALSE, NULL);
lpWorker->ECommand = WORKER_CMD_NONE;
lpWorker->hThread = CreateThread(
NULL,
THREAD_WORKERS_MEM,
worker_wait,
(LPVOID)lpWorker,
0,
NULL);
return lpWorker;
};
static void init_shared_globals(char* mem) {
size_t page_size = getpagesize();
#ifdef _WIN32
if (!VirtualAlloc(mem,
global_size_b + page_size +
2 * DEP_SIZE_B + HASHTBL_SIZE_B,
MEM_COMMIT, PAGE_READWRITE)) {
win32_maperr(GetLastError());
uerror("VirtualAlloc2", Nothing);
}
#endif
/* Global storage initialization:
* We store this at the start of the shared memory section as it never
* needs to get saved (always reset after each typechecking run) */
global_storage = (value*)mem;
// Initial size is zero
global_storage[0] = 0;
mem += global_size_b;
/* BEGINNING OF THE SMALL OBJECTS PAGE
* We keep all the small objects in this page.
* They are on different cache lines because we modify them atomically.
*/
/* The pointer to the top of the heap.
* We will atomically increment *heap every time we want to allocate.
*/
heap = (char**)mem;
assert(CACHE_LINE_SIZE >= sizeof(char*));
// The number of elements in the hashtable
hcounter = (int*)(mem + CACHE_LINE_SIZE);
*hcounter = 0;
counter = (uintptr_t*)(mem + 2*CACHE_LINE_SIZE);
*counter = early_counter + 1;
mem += page_size;
// Just checking that the page is large enough.
assert(page_size > CACHE_LINE_SIZE + (int)sizeof(int));
/* END OF THE SMALL OBJECTS PAGE */
/* Dependencies */
deptbl = (uint64*)mem;
mem += DEP_SIZE_B;
deptbl_bindings = (uint64*)mem;
mem += DEP_SIZE_B;
/* Hashtable */
hashtbl = (helt_t*)mem;
mem += HASHTBL_SIZE_B;
/* Heap */
heap_init = mem;
*heap = mem;
}
CAMLprim value win_findclose(value valh)
{
if (! FindClose(Handle_val(valh))) {
win32_maperr(GetLastError());
uerror("closedir", Nothing);
}
return Val_unit;
}
CAMLprim value win_utimes (value path, value wpath, value atime, value mtime) {
HANDLE h;
BOOL res;
ULARGE_INTEGER iatime, imtime;
FILETIME fatime, fmtime;
CAMLparam4(path, wpath, atime, mtime);
iatime.QuadPart = Double_val(atime);
imtime.QuadPart = Double_val(mtime);
/* http://www.filewatcher.com/p/Win32-UTCFileTime-1.44.tar.gz.93147/Win32-UTCFileTime-1.44/UTCFileTime.xs.html */
/* http://savannah.nongnu.org/bugs/?22781#comment0 */
if (iatime.QuadPart || imtime.QuadPart) {
iatime.QuadPart += 11644473600ull;
iatime.QuadPart *= 10000000ull;
fatime.dwLowDateTime = iatime.LowPart;
fatime.dwHighDateTime = iatime.HighPart;
imtime.QuadPart += 11644473600ull;
imtime.QuadPart *= 10000000ull;
fmtime.dwLowDateTime = imtime.LowPart;
fmtime.dwHighDateTime = imtime.HighPart;
} else {
GetSystemTimeAsFileTime (&fatime);
fmtime = fatime;
}
h = CreateFileW ((LPWSTR) wpath, FILE_WRITE_ATTRIBUTES,
FILE_SHARE_READ | FILE_SHARE_WRITE,
NULL, OPEN_EXISTING, 0, NULL);
if (h == INVALID_HANDLE_VALUE) {
win32_maperr (GetLastError ());
uerror("utimes", path);
}
res = SetFileTime (h, NULL, &fatime, &fmtime);
if (res == 0) {
win32_maperr (GetLastError ());
(void)CloseHandle (h);
uerror("utimes", path);
}
res = CloseHandle (h);
if (res == 0) {
win32_maperr (GetLastError ());
uerror("utimes", path);
}
CAMLreturn (Val_unit);
}
value lwt_unix_recv_notifications()
{
int ret, i, current_index;
value result;
#if !defined(LWT_ON_WINDOWS)
sigset_t new_mask;
sigset_t old_mask;
int error;
sigfillset(&new_mask);
pthread_sigmask(SIG_SETMASK, &new_mask, &old_mask);
#else
DWORD error;
#endif
lwt_unix_mutex_lock(¬ification_mutex);
/* Receive the signal. */
ret = notification_recv();
#if defined(LWT_ON_WINDOWS)
if (ret == SOCKET_ERROR) {
error = WSAGetLastError();
lwt_unix_mutex_unlock(¬ification_mutex);
win32_maperr(error);
uerror("recv_notifications", Nothing);
}
#else
if (ret < 0) {
error = errno;
lwt_unix_mutex_unlock(¬ification_mutex);
pthread_sigmask(SIG_SETMASK, &old_mask, NULL);
unix_error(error, "recv_notifications", Nothing);
}
#endif
do {
/*
release the mutex while calling caml_alloc,
which may call gc and switch the thread,
resulting in a classical deadlock,
when thread in question tries another send
*/
current_index = notification_index;
lwt_unix_mutex_unlock(¬ification_mutex);
result = caml_alloc_tuple(current_index);
lwt_unix_mutex_lock(¬ification_mutex);
/* check that no new notifications appeared meanwhile (rare) */
}
while (current_index != notification_index);
/* Read all pending notifications. */
for (i = 0; i < notification_index; i++)
Field(result, i) = Val_long(notifications[i]);
/* Reset the index. */
notification_index = 0;
lwt_unix_mutex_unlock(¬ification_mutex);
#if !defined(LWT_ON_WINDOWS)
pthread_sigmask(SIG_SETMASK, &old_mask, NULL);
#endif
return result;
}
CAMLprim value netsys_unix_error_of_code(value n) {
int e;
e = Int_val(n);
#ifdef _WIN32
win32_maperr(e);
e = errno;
#endif
return(unix_error_of_code(e));
}
CAMLprim value win_rmdir(value path, value wpath)
{
CAMLparam2(path, wpath);
if (!RemoveDirectoryW((LPWSTR)String_val(wpath))) {
win32_maperr (GetLastError ());
uerror("rmdir", path);
}
CAMLreturn (Val_unit);
}
CAMLprim value win_mkdir(value path, value wpath)
{
CAMLparam2(path, wpath);
if (!CreateDirectoryW((LPWSTR)String_val(wpath), NULL)) {
win32_maperr (GetLastError ());
uerror("mkdir", path);
}
CAMLreturn (Val_unit);
}
CAMLprim value win_unlink(value path, value wpath)
{
CAMLparam2(path, wpath);
if (!DeleteFileW((LPWSTR)String_val(wpath))) {
win32_maperr (GetLastError ());
uerror("unlink", path);
}
CAMLreturn (Val_unit);
}
CAMLprim value win_set_console_output_cp (value cp) {
BOOL res;
res = SetConsoleOutputCP (Int_val (cp));
if (res == 0) {
win32_maperr (GetLastError ());
uerror("set_console_cp", Nothing);
}
return (Val_unit);
}
CAMLprim value win_chdir (value path, value wpath)
{
CAMLparam2(path,wpath);
if (!SetCurrentDirectoryW ((LPWSTR)wpath)) {
win32_maperr(GetLastError());
uerror("chdir", path);
}
CAMLreturn (Val_unit);
}
value win_pipe(long readMode, long writeMode) {
CAMLparam0();
SECURITY_ATTRIBUTES attr;
HANDLE readh, writeh;
CHAR name[MAX_PATH];
CAMLlocal3(readfd, writefd, res);
attr.nLength = sizeof(attr);
attr.lpSecurityDescriptor = NULL;
attr.bInheritHandle = TRUE;
sprintf(name, "\\\\.\\Pipe\\UnisonAnonPipe.%08lx.%08lx",
GetCurrentProcessId(), pipeSerial++);
readh =
CreateNamedPipeA
(name, PIPE_ACCESS_INBOUND | readMode, PIPE_TYPE_BYTE | PIPE_WAIT,
1, UNIX_BUFFER_SIZE, UNIX_BUFFER_SIZE, 0, &attr);
if (readh == INVALID_HANDLE_VALUE) {
win32_maperr(GetLastError());
uerror("CreateNamedPipe", Nothing);
return FALSE;
}
writeh =
CreateFileA
(name, GENERIC_WRITE, 0, &attr, OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL | writeMode, NULL);
if (writeh == INVALID_HANDLE_VALUE) {
win32_maperr(GetLastError());
CloseHandle(readh);
uerror("CreateFile", Nothing);
return FALSE;
}
readfd = win_alloc_handle(readh);
writefd = win_alloc_handle(writeh);
res = alloc_small(2, 0);
Store_field(res, 0, readfd);
Store_field(res, 1, writefd);
CAMLreturn (res);
}
