lwt_unix_stubs.c (19655B)
1 #include <winsock2.h> 2 #include <windows.h> 3 #include <errno.h> 4 #include <stdio.h> 5 6 #include <caml/mlvalues.h> 7 #include <caml/alloc.h> 8 #include <caml/memory.h> 9 #include <caml/fail.h> 10 #include <caml/bigarray.h> 11 #include <caml/callback.h> 12 #include <caml/unixsupport.h> 13 #include <caml/socketaddr.h> 14 #include <caml/version.h> 15 #if OCAML_VERSION < 41300 16 #define CAML_INTERNALS /* was needed from OCaml 4.06 to 4.12 */ 17 #endif 18 #include <caml/osdeps.h> 19 20 #if OCAML_VERSION_MAJOR < 5 21 #define caml_unix_cloexec_p unix_cloexec_p 22 #define caml_unix_error_of_code unix_error_of_code 23 #define caml_uerror uerror 24 #define caml_win32_maperr win32_maperr 25 #define caml_win32_alloc_handle win_alloc_handle 26 #define caml_win32_alloc_socket win_alloc_socket 27 #endif 28 29 //#define D(x) x 30 #define D(x) while(0){} 31 32 typedef struct 33 { 34 OVERLAPPED overlapped; 35 long id; 36 long action; 37 } completionData; 38 39 #define Array_data(a, i) (((char *) Caml_ba_data_val(a)) + Long_val(i)) 40 41 #ifndef Bytes_val 42 #define Bytes_val(x) ((unsigned char *) Bp_val(x)) 43 #endif 44 45 CAMLprim value ml_blit_bytes_to_buffer 46 (value s, value i, value a, value j, value l) 47 { 48 CAMLparam5(s, i, a, j, l); 49 unsigned char *src = Bytes_val(s) + Long_val(i); 50 char *dest = Array_data(a, j); 51 memcpy(dest, src, Long_val(l)); 52 CAMLreturn(Val_unit); 53 } 54 55 CAMLprim value ml_blit_string_to_buffer 56 (value s, value i, value a, value j, value l) 57 { 58 return ml_blit_bytes_to_buffer(s, i, a, j, l); 59 } 60 61 CAMLprim value ml_blit_buffer_to_bytes 62 (value a, value i, value s, value j, value l) 63 { 64 CAMLparam5(a, i, s, j, l); 65 char *src = Array_data(a, i); 66 unsigned char *dest = Bytes_val(s) + Long_val(j); 67 memcpy(dest, src, Long_val(l)); 68 CAMLreturn(Val_unit); 69 } 70 71 /****/ 72 73 #define READ 0 74 #define WRITE 1 75 #define READ_OVERLAPPED 2 76 #define WRITE_OVERLAPPED 3 77 #define READDIRECTORYCHANGES 4 78 static char * action_name[5] = { 79 "read", "write", "read(overlapped)", "write(overlapped)", 80 "ReadDirectoryChangesW" 81 }; 82 83 static value completionCallback; 84 85 static void invoke_completion_callback 86 (long id, long len, long errCode, long action) { 87 CAMLparam0(); 88 CAMLlocal2 (err, name); 89 value args[4]; 90 err = Val_long(0); 91 if (errCode != NO_ERROR) { 92 len = -1; 93 caml_win32_maperr(errCode); 94 err = caml_unix_error_of_code(errno); 95 } 96 name = caml_copy_string(action_name[action]); 97 D(printf("Action %s completed: id %ld -> len %ld / err %d (errCode %ld)\n", 98 action_name[action], id, len, errno, errCode)); 99 args[0] = Val_long(id); 100 args[1] = Val_long(len); 101 args[2] = err; 102 args[3] = name; 103 caml_callbackN(completionCallback, 4, args); 104 D(printf("Callback performed\n")); 105 CAMLreturn0; 106 } 107 108 typedef struct { 109 long id; 110 long len; 111 long errCode; 112 long action; } completionInfo; 113 114 int compN = 0; 115 int complQueueSize = 0; 116 completionInfo * complQueue = NULL; 117 118 static void completion (long id, long len, long errCode, long action) { 119 D(printf("Queueing action %s: id %ld -> len %ld / err %d (errCode %ld)\n", 120 action_name[action], id, len, errno, errCode)); 121 if (compN + 1 > complQueueSize) { 122 completionInfo * queue; 123 int n = complQueueSize * 2 + 1; 124 D(printf("Resizing queue to %d\n", n)); 125 queue = (completionInfo *) GlobalAlloc(GPTR, n * sizeof(completionInfo)); 126 if (complQueue != NULL) 127 CopyMemory (queue, complQueue, complQueueSize * sizeof(completionInfo)); 128 complQueue = queue; 129 complQueueSize = n; 130 } 131 complQueue[compN].id = id; 132 complQueue[compN].len = len; 133 complQueue[compN].errCode = errCode; 134 complQueue[compN].action = action; 135 compN++; 136 } 137 138 CAMLprim value get_queue (value unit) { 139 CAMLparam1 (unit); 140 int i; 141 for (i = 0; i < compN; i++) 142 invoke_completion_callback 143 (complQueue[i].id, complQueue[i].len, 144 complQueue[i].errCode, complQueue[i].action); 145 compN = 0; 146 CAMLreturn (Val_unit); 147 } 148 149 /****/ 150 151 static HANDLE main_thread; 152 153 static DWORD CALLBACK helper_thread (void * param) { 154 D(printf("Helper thread created\n")); 155 while (1) SleepEx(INFINITE, TRUE); 156 return 0; 157 } 158 159 static VOID CALLBACK exit_thread(ULONG_PTR param) { 160 D(printf("Helper thread exiting\n")); 161 ExitThread(0); 162 } 163 164 static HANDLE get_helper_thread (value threads, int kind) { 165 HANDLE h = (HANDLE) Field(threads, kind); 166 167 if (h != INVALID_HANDLE_VALUE) return h; 168 169 h = CreateThread (NULL, 0, helper_thread, NULL, 0, NULL); 170 if (h == NULL) { 171 caml_win32_maperr(GetLastError()); 172 caml_uerror("createHelperThread", Nothing); 173 } 174 Field(threads, kind) = (value) h; 175 return h; 176 } 177 178 static void kill_thread (HANDLE *h) { 179 D(printf("Killing thread\n")); 180 QueueUserAPC(exit_thread, *h, 0); 181 CloseHandle(*h); 182 *h = INVALID_HANDLE_VALUE; 183 } 184 185 CAMLprim value win_kill_threads (value fd) { 186 CAMLparam1(fd); 187 if (Field(fd, 1) != Val_long(0)) { 188 kill_thread((HANDLE *) &Field(Field(fd, 1), READ)); 189 kill_thread((HANDLE *) &Field(Field(fd, 1), WRITE)); 190 } 191 CAMLreturn(Val_unit); 192 } 193 194 CAMLprim value win_wrap_fd (value fd) { 195 CAMLparam1(fd); 196 CAMLlocal2(th, res); 197 D(printf("Wrapping file descriptor (sync)\n")); 198 res = caml_alloc_tuple(2); 199 Store_field(res, 0, fd); 200 th = caml_alloc(2, Abstract_tag); 201 Field(th, READ) = (value) INVALID_HANDLE_VALUE; 202 Field(th, WRITE) = (value) INVALID_HANDLE_VALUE; 203 Store_field(res, 1, th); 204 CAMLreturn(res); 205 } 206 207 /****/ 208 209 typedef struct { 210 long action; 211 long id; 212 HANDLE fd; 213 char * buffer; 214 long len; 215 long error; 216 } ioInfo; 217 218 219 static VOID CALLBACK thread_completion(ULONG_PTR param) { 220 ioInfo * info = (ioInfo *) param; 221 completion (info->id, info->len, info->error, info->action); 222 GlobalFree (info); 223 } 224 225 static VOID CALLBACK perform_io_on_thread(ULONG_PTR param) { 226 ioInfo * info = (ioInfo *) param; 227 DWORD l; 228 BOOL res; 229 230 D(printf("Starting %s: id %ld, len %ld\n", 231 action_name[info->action], info->id, info->len)); 232 233 res = 234 (info->action == READ)? 235 ReadFile(info->fd, info->buffer,info->len, &l, NULL): 236 WriteFile(info->fd, info->buffer,info->len, &l, NULL); 237 if (!res) { 238 info->len = -1; 239 info->error = GetLastError (); 240 } else { 241 info->len = l; 242 info->error = NO_ERROR; 243 } 244 D(printf("Action %s done: id %ld -> len %ld / err %d (errCode %ld)\n", 245 action_name[info->action], 246 info->id, info->len, errno, info->error)); 247 QueueUserAPC(thread_completion, main_thread, param); 248 } 249 250 static void thread_io 251 (long action, long id, value threads, HANDLE h, char * buf, long len) { 252 ioInfo * info = GlobalAlloc(GPTR, sizeof(ioInfo)); 253 if (info == NULL) { 254 errno = ENOMEM; 255 caml_uerror(action_name[action], Nothing); 256 } 257 258 info->action = action; 259 info->id = id; 260 info->fd = h; 261 info->buffer = buf; 262 info->len = len; 263 264 h = get_helper_thread(threads, action); 265 QueueUserAPC(perform_io_on_thread, h, (ULONG_PTR) info); 266 } 267 268 /****/ 269 270 static void CALLBACK overlapped_completion 271 (DWORD errCode, DWORD len, LPOVERLAPPED overlapped) { 272 completionData * d = (completionData * )overlapped; 273 completion (d->id, len, errCode, d->action); 274 GlobalFree (d); 275 } 276 277 static void overlapped_action(long action, long id, 278 HANDLE fd, char *buf, long len) { 279 BOOL res; 280 long err; 281 completionData * d = GlobalAlloc(GPTR, sizeof(completionData)); 282 if (d == NULL) { 283 errno = ENOMEM; 284 caml_uerror(action_name[action], Nothing); 285 } 286 d->id = id; 287 d->action = action; 288 289 D(printf("Starting %s: id %ld, len %ld\n", action_name[action], id, len)); 290 res = 291 (action == READ_OVERLAPPED)? 292 ReadFileEx(fd, buf, len, &(d->overlapped), overlapped_completion): 293 WriteFileEx(fd, buf, len, &(d->overlapped), overlapped_completion); 294 295 if (!res) { 296 err = GetLastError (); 297 if (err != ERROR_IO_PENDING) { 298 caml_win32_maperr(err); 299 D(printf("Action %s failed: id %ld -> err %d (errCode %ld)\n", 300 action_name[action], id, errno, err)); 301 caml_uerror("ReadFileEx", Nothing); 302 } 303 } 304 } 305 306 CAMLprim value win_wrap_overlapped (value fd) { 307 CAMLparam1(fd); 308 CAMLlocal1(res); 309 D(printf("Wrapping file descriptor (async)\n")); 310 res = caml_alloc_tuple(2); 311 Store_field(res, 0, fd); 312 Store_field(res, 1, Val_long(0)); 313 CAMLreturn(res); 314 } 315 316 /****/ 317 318 #define Handle(fd) Handle_val(Field(fd, 0)) 319 320 CAMLprim value win_read 321 (value fd, value buf, value ofs, value len, value id) { 322 CAMLparam5(fd, buf, ofs, len, id); 323 324 if (Field(fd, 1) == Val_long(0)) 325 overlapped_action (READ_OVERLAPPED, Long_val(id), Handle(fd), 326 Array_data(buf, ofs), Long_val(len)); 327 else 328 thread_io (READ, Long_val(id), Field(fd, 1), Handle(fd), 329 Array_data(buf, ofs), Long_val(len)); 330 CAMLreturn (Val_unit); 331 } 332 333 CAMLprim value win_write 334 (value fd, value buf, value ofs, value len, value id) { 335 CAMLparam5(fd, buf, ofs, len, id); 336 337 if (Field(fd, 1) == Val_long(0)) 338 overlapped_action (WRITE_OVERLAPPED, Long_val(id), Handle(fd), 339 Array_data(buf, ofs), Long_val(len)); 340 else 341 thread_io (WRITE, Long_val(id), Field(fd, 1), Handle(fd), 342 Array_data(buf, ofs), Long_val(len)); 343 CAMLreturn (Val_unit); 344 } 345 346 /* 347 #ifndef SO_UPDATE_CONNECT_CONTEXT 348 #define SO_UPDATE_CONNECT_CONTEXT 0x7010 349 #endif 350 351 static void after_connect (SOCKET s) { 352 if (!setsockopt(s, SOL_SOCKET, SO_UPDATE_CONNECT_CONTEXT, NULL, 0)) { 353 win32_maperr (GetLastError ()); 354 uerror("after_connect", Nothing); 355 } 356 } 357 */ 358 359 static HANDLE events[MAXIMUM_WAIT_OBJECTS]; 360 //static OVERLAPPED oData[MAXIMUM_WAIT_OBJECTS]; 361 362 CAMLprim value win_register_wait (value socket, value kind) { 363 CAMLparam2(socket, kind); 364 HANDLE h; 365 long mask; 366 367 D(printf("Register: %lx, kind %ld\n", (long)(Socket_val(socket)), Long_val(kind))); 368 h = CreateEvent(NULL, TRUE, FALSE, NULL); 369 mask = (Long_val(kind) == 0) ? FD_CONNECT : FD_ACCEPT; 370 if (WSAEventSelect(Socket_val(socket), h, mask) == SOCKET_ERROR) { 371 caml_win32_maperr(WSAGetLastError()); 372 caml_uerror("WSAEventSelect", Nothing); 373 } 374 375 CAMLreturn(caml_win32_alloc_handle(h)); 376 } 377 378 CAMLprim value win_check_connection (value socket, value kind, value h) { 379 CAMLparam3 (socket, kind, h); 380 WSANETWORKEVENTS evs; 381 int res, err; 382 383 D(printf("Check connection... socket = %lx; h = %lx\n", 384 (long)(Socket_val(socket)), Handle_val(h))); 385 if (WSAEnumNetworkEvents(Socket_val(socket), NULL, &evs)) { 386 caml_win32_maperr(WSAGetLastError()); 387 caml_uerror("WSAEnumNetworkEvents", Nothing); 388 } 389 if (WSAEventSelect(Socket_val(socket), NULL, 0) == SOCKET_ERROR) { 390 caml_win32_maperr(WSAGetLastError()); 391 caml_uerror("WSAEventSelect", Nothing); 392 } 393 if (!CloseHandle(Handle_val(h))) { 394 caml_win32_maperr(GetLastError()); 395 caml_uerror("CloseHandle", Nothing); 396 } 397 err = 398 evs.iErrorCode[(Long_val(kind) == 0) ? FD_CONNECT_BIT : FD_ACCEPT_BIT]; 399 D(printf("Check connection: %ld, err %d\n", evs.lNetworkEvents, err)); 400 if (err != 0) { 401 caml_win32_maperr(err); 402 caml_uerror("check_connection", Nothing); 403 } 404 CAMLreturn (Val_unit); 405 } 406 407 static HANDLE dummyEvent; 408 409 CAMLprim value init_lwt (value callb) { 410 CAMLparam1 (callb); 411 // GUID GuidConnectEx = WSAID_CONNECTEX; 412 // SOCKET s; 413 // DWORD l; 414 int i; 415 416 D(printf("Init...\n")); 417 caml_register_global_root(&completionCallback); 418 completionCallback = callb; 419 420 dummyEvent = CreateEvent(NULL, TRUE, FALSE, NULL); // Dummy event 421 422 DuplicateHandle (GetCurrentProcess (), GetCurrentThread (), 423 GetCurrentProcess (), &main_thread, 424 0, FALSE, DUPLICATE_SAME_ACCESS); 425 426 /* 427 s = socket(AF_INET, SOCK_STREAM, 0); 428 if (s == INVALID_SOCKET) return Val_unit; 429 WSAIoctl(s, SIO_GET_EXTENSION_FUNCTION_POINTER, 430 &GuidConnectEx, sizeof(GuidConnectEx), 431 &ConnectEx, sizeof(ConnectExPtr), 432 &l, NULL, NULL); 433 closesocket(s); 434 */ 435 436 D(printf("Init done\n")); 437 CAMLreturn (Val_long (MAXIMUM_WAIT_OBJECTS)); 438 } 439 440 CAMLprim value win_wait (value timeout, value event_list) { 441 CAMLparam2(timeout, event_list); 442 DWORD t, t2; 443 DWORD res; 444 long ret, n; 445 t = Long_val(timeout); 446 if (t < 0) t = INFINITE; 447 t2 = (compN > 0) ? 0 : t; 448 for (n = 0; event_list != Val_emptylist; event_list = Field(event_list, 1)) 449 events[n++] = Handle_val(Field(event_list, 0)); 450 D(printf("Waiting: %ld events, timeout %ldms -> %ldms\n", n, t, t2)); 451 res = 452 (n > 0) ? 453 WaitForMultipleObjectsEx(n, events, FALSE, t, TRUE) : 454 WaitForMultipleObjectsEx(1, &dummyEvent, FALSE, t, TRUE); 455 D(printf("Done waiting\n")); 456 if ((t != t2) && (res == WAIT_TIMEOUT)) res = WAIT_IO_COMPLETION; 457 switch (res) { 458 case WAIT_TIMEOUT: 459 D(printf("Timeout\n")); 460 ret = -1; 461 break; 462 case WAIT_IO_COMPLETION: 463 D(printf("I/O completion\n")); 464 ret = -2; 465 break; 466 case WAIT_FAILED: 467 D(printf("Wait failed\n")); 468 ret = 0; 469 caml_win32_maperr(GetLastError()); 470 caml_uerror("WaitForMultipleObjectsEx", Nothing); 471 break; 472 default: 473 ret = res; 474 D(printf("Event: %ld\n", res)); 475 break; 476 } 477 get_queue (Val_unit); 478 CAMLreturn (Val_long(ret)); 479 } 480 481 static long pipeSerial; 482 483 value win_pipe(int cloexec, long readMode, long writeMode) { 484 CAMLparam0(); 485 SECURITY_ATTRIBUTES attr; 486 HANDLE readh, writeh; 487 CHAR name[MAX_PATH]; 488 CAMLlocal3(readfd, writefd, res); 489 490 attr.nLength = sizeof(attr); 491 attr.lpSecurityDescriptor = NULL; 492 attr.bInheritHandle = cloexec ? FALSE : TRUE; 493 494 sprintf(name, "\\\\.\\Pipe\\UnisonAnonPipe.%08lx.%08lx", 495 GetCurrentProcessId(), pipeSerial++); 496 497 readh = 498 CreateNamedPipeA 499 (name, PIPE_ACCESS_INBOUND | readMode, PIPE_TYPE_BYTE | PIPE_WAIT, 500 1, UNIX_BUFFER_SIZE, UNIX_BUFFER_SIZE, 0, &attr); 501 502 if (readh == INVALID_HANDLE_VALUE) { 503 caml_win32_maperr(GetLastError()); 504 caml_uerror("CreateNamedPipe", Nothing); 505 return FALSE; 506 } 507 508 writeh = 509 CreateFileA 510 (name, GENERIC_WRITE, 0, &attr, OPEN_EXISTING, 511 FILE_ATTRIBUTE_NORMAL | writeMode, NULL); 512 513 if (writeh == INVALID_HANDLE_VALUE) { 514 caml_win32_maperr(GetLastError()); 515 CloseHandle(readh); 516 caml_uerror("CreateFile", Nothing); 517 return FALSE; 518 } 519 520 readfd = caml_win32_alloc_handle(readh); 521 writefd = caml_win32_alloc_handle(writeh); 522 res = caml_alloc_small(2, 0); 523 Field(res, 0) = readfd; 524 Field(res, 1) = writefd; 525 CAMLreturn (res); 526 } 527 528 CAMLprim value win_pipe_in (value cloexec, value unit) { 529 CAMLparam0(); 530 CAMLreturn (win_pipe (caml_unix_cloexec_p(cloexec), FILE_FLAG_OVERLAPPED, 0)); 531 } 532 533 CAMLprim value win_pipe_out (value cloexec, value unit) { 534 CAMLparam0(); 535 CAMLreturn (win_pipe (caml_unix_cloexec_p(cloexec), 0, FILE_FLAG_OVERLAPPED)); 536 } 537 538 static int socket_domain_table[] = { 539 PF_UNIX, PF_INET, PF_INET6 540 }; 541 542 static int socket_type_table[] = { 543 SOCK_STREAM, SOCK_DGRAM, SOCK_RAW, SOCK_SEQPACKET 544 }; 545 546 CAMLprim value win_socket (value cloexec, value domain, value type, value proto) { 547 CAMLparam3(domain, type, proto); 548 SOCKET s; 549 550 s = WSASocket(socket_domain_table[Int_val(domain)], 551 socket_type_table[Int_val(type)], 552 Int_val(proto), 553 NULL, 0, WSA_FLAG_OVERLAPPED); 554 D(printf("Created socket %lx\n", (long)s)); 555 if (s == INVALID_SOCKET) { 556 caml_win32_maperr(WSAGetLastError()); 557 caml_uerror("WSASocket", Nothing); 558 } 559 /* Ignore errors */ 560 SetHandleInformation((HANDLE) s, HANDLE_FLAG_INHERIT, 561 unix_cloexec_p(cloexec) ? 0 : HANDLE_FLAG_INHERIT); 562 CAMLreturn(caml_win32_alloc_socket(s)); 563 } 564 565 /* 566 #ifndef WSAID_CONNECTEX 567 #define WSAID_CONNECTEX \ 568 {0x25a207b9,0xddf3,0x4660,{0x8e,0xe9,0x76,0xe5,0x8c,0x74,0x06,0x3e}} 569 #endif 570 571 typedef BOOL (WINAPI *ConnectExPtr)(SOCKET, const struct sockaddr *, int, PVOID, DWORD, LPDWORD, LPOVERLAPPED); 572 573 static ConnectExPtr ConnectEx = NULL; 574 575 CAMLprim value win_connect (value socket, value address, value id) { 576 CAMLparam3(socket, address, id); 577 SOCKET s = Socket_val (socket); 578 struct sockaddr addr; 579 int addr_len; 580 DWORD err; 581 int i; 582 583 if (ConnectEx == NULL) { 584 errno = ENOSYS; 585 uerror("ConnectEx", Nothing); 586 } 587 if (eventCount == MAXIMUM_WAIT_OBJECTS) { 588 errno = EAGAIN; 589 uerror("ConnectEx", Nothing); 590 } 591 i = free_list[eventCount]; 592 eventCount++; 593 594 ZeroMemory(&(oData[i]), sizeof(OVERLAPPED)); 595 oData[i].hEvent = events[i]; 596 ids[i] = Long_val(id); 597 sockets[i] = s; 598 599 get_sockaddr(address, &addr, &addr_len); 600 if (!ConnectEx(s, &addr, addr_len, NULL, 0, 0, &(oData[i]))) { 601 err = WSAGetLastError (); 602 if (err != ERROR_IO_PENDING) { 603 win32_maperr(err); 604 uerror("ConnectEx", Nothing); 605 } 606 } else 607 after_connect(s); 608 CAMLreturn (Val_unit); 609 } 610 */ 611 612 static int notify_filter_flags[8] = { 613 FILE_NOTIFY_CHANGE_FILE_NAME, FILE_NOTIFY_CHANGE_DIR_NAME, 614 FILE_NOTIFY_CHANGE_ATTRIBUTES, FILE_NOTIFY_CHANGE_SIZE, 615 FILE_NOTIFY_CHANGE_LAST_WRITE, FILE_NOTIFY_CHANGE_LAST_ACCESS, 616 FILE_NOTIFY_CHANGE_CREATION, FILE_NOTIFY_CHANGE_SECURITY 617 }; 618 619 CAMLprim value win_readdirtorychanges 620 (value fd_val, value buf_val, value recursive, value flags, value id_val) { 621 CAMLparam5(fd_val, buf_val, recursive, flags, id_val); 622 long id = Long_val(id_val); 623 HANDLE fd = Handle_val(fd_val); 624 char * buf = Array_data(buf_val, 0); 625 long len = Caml_ba_array_val(buf_val)->dim[0]; 626 long action = READDIRECTORYCHANGES; 627 BOOL res; 628 long err; 629 int notify_filter = caml_convert_flag_list(flags, notify_filter_flags); 630 completionData * d = GlobalAlloc(GPTR, sizeof(completionData)); 631 if (d == NULL) { 632 errno = ENOMEM; 633 caml_uerror(action_name[action], Nothing); 634 } 635 d->id = id; 636 d->action = action; 637 638 D(printf("Starting %s: id %ld, len %ld\n", action_name[action], id, len)); 639 640 res = ReadDirectoryChangesW (fd, buf, len, Bool_val(recursive), 641 notify_filter, NULL, &(d->overlapped), 642 overlapped_completion); 643 644 if (!res) { 645 err = GetLastError (); 646 if (err != ERROR_IO_PENDING) { 647 caml_win32_maperr(err); 648 D(printf("Action %s failed: id %ld -> err %d (errCode %ld)\n", 649 action_name[action], id, errno, err)); 650 caml_uerror("ReadDirectoryChangesW", Nothing); 651 } 652 } 653 CAMLreturn (Val_unit); 654 } 655 656 CAMLprim value win_parse_directory_changes (value buf_val) { 657 CAMLparam1(buf_val); 658 CAMLlocal4(lst, tmp, elt, filename); 659 char * pos = Array_data(buf_val, 0); 660 FILE_NOTIFY_INFORMATION * entry; 661 wchar_t *namebuf; 662 663 lst = Val_long(0); 664 while (1) { 665 entry = (FILE_NOTIFY_INFORMATION *)pos; 666 namebuf = calloc(entry->FileNameLength + 2, 1); 667 memmove(namebuf, entry->FileName, entry->FileNameLength); 668 elt = caml_alloc_tuple(2); 669 Store_field (elt, 0, caml_copy_string_of_utf16(namebuf)); 670 free(namebuf); 671 Store_field (elt, 1, Val_long(entry->Action - 1)); 672 tmp = caml_alloc_tuple(2); 673 Store_field (tmp, 0, elt); 674 Store_field (tmp, 1, lst); 675 lst = tmp; 676 if (entry->NextEntryOffset == 0) break; 677 pos += entry->NextEntryOffset; 678 } 679 CAMLreturn(lst); 680 } 681 682 CAMLprim value win_open_directory (value path) { 683 CAMLparam1 (path); 684 HANDLE h; 685 wchar_t *wpath = caml_stat_strdup_to_utf16(String_val(path)); 686 687 h = CreateFileW(wpath, 688 FILE_LIST_DIRECTORY, 689 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, 690 NULL, 691 OPEN_EXISTING, 692 FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OVERLAPPED, 693 NULL); 694 caml_stat_free(wpath); 695 if (h == INVALID_HANDLE_VALUE) { 696 caml_win32_maperr(GetLastError()); 697 caml_uerror("open", path); 698 } 699 CAMLreturn(caml_win32_alloc_handle(h)); 700 } 701 702 CAMLprim value win_long_path_name(value path) { 703 CAMLparam1(path); 704 wchar_t *wpath = caml_stat_strdup_to_utf16(String_val(path)); 705 wchar_t lbuf[32768] = L""; 706 DWORD res; 707 708 res = GetLongPathNameW(wpath, lbuf, 32768); 709 caml_stat_free(wpath); 710 711 CAMLreturn(res == 0 || res > 32767 ? path : caml_copy_string_of_utf16(lbuf)); 712 }