system_win_stubs.c (21180B)
1 #define WINVER 0x0500 2 3 #include <winsock2.h> 4 #include <windows.h> 5 #include <fcntl.h> 6 #include <sys/stat.h> 7 #include <stdio.h> 8 #include <stdint.h> 9 10 #include <caml/mlvalues.h> 11 #include <caml/alloc.h> 12 #include <caml/memory.h> 13 #include <caml/fail.h> 14 #include <caml/unixsupport.h> 15 #include <caml/version.h> 16 #if OCAML_VERSION < 41300 17 #define CAML_INTERNALS /* was needed from OCaml 4.06 to 4.12 */ 18 #endif 19 #include <caml/osdeps.h> 20 21 #if OCAML_VERSION_MAJOR < 5 22 #define caml_uerror uerror 23 #define caml_win32_maperr win32_maperr 24 #define caml_win32_alloc_handle win_alloc_handle 25 #endif 26 27 28 /* Parts of code in the following section are originally copied from libuv. 29 * 30 * libuv 31 * Copyright Joyent, Inc. and other Node contributors. All rights reserved. 32 * 33 * Permission is hereby granted, free of charge, to any person obtaining a copy 34 * of this software and associated documentation files (the "Software"), to 35 * deal in the Software without restriction, including without limitation the 36 * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or 37 * sell copies of the Software, and to permit persons to whom the Software is 38 * furnished to do so, subject to the following conditions: 39 * 40 * The above copyright notice and this permission notice shall be included in 41 * all copies or substantial portions of the Software. 42 * 43 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 44 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 45 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 46 * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 47 * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 48 * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 49 * IN THE SOFTWARE. 50 */ 51 /* BEGIN section originally copied from libuv win/winapi.h */ 52 53 typedef struct _IO_STATUS_BLOCK { 54 union { 55 NTSTATUS Status; 56 PVOID Pointer; 57 }; 58 ULONG_PTR Information; 59 } IO_STATUS_BLOCK, *PIO_STATUS_BLOCK; 60 61 typedef struct _FILE_BASIC_INFORMATION { 62 LARGE_INTEGER CreationTime; 63 LARGE_INTEGER LastAccessTime; 64 LARGE_INTEGER LastWriteTime; 65 LARGE_INTEGER ChangeTime; 66 DWORD FileAttributes; 67 } FILE_BASIC_INFORMATION, *PFILE_BASIC_INFORMATION; 68 69 typedef struct _FILE_STANDARD_INFORMATION { 70 LARGE_INTEGER AllocationSize; 71 LARGE_INTEGER EndOfFile; 72 ULONG NumberOfLinks; 73 BOOLEAN DeletePending; 74 BOOLEAN Directory; 75 } FILE_STANDARD_INFORMATION, *PFILE_STANDARD_INFORMATION; 76 77 typedef struct _FILE_INTERNAL_INFORMATION { 78 LARGE_INTEGER IndexNumber; 79 } FILE_INTERNAL_INFORMATION, *PFILE_INTERNAL_INFORMATION; 80 81 typedef struct _FILE_EA_INFORMATION { 82 ULONG EaSize; 83 } FILE_EA_INFORMATION, *PFILE_EA_INFORMATION; 84 85 typedef struct _FILE_ACCESS_INFORMATION { 86 ACCESS_MASK AccessFlags; 87 } FILE_ACCESS_INFORMATION, *PFILE_ACCESS_INFORMATION; 88 89 typedef struct _FILE_POSITION_INFORMATION { 90 LARGE_INTEGER CurrentByteOffset; 91 } FILE_POSITION_INFORMATION, *PFILE_POSITION_INFORMATION; 92 93 typedef struct _FILE_MODE_INFORMATION { 94 ULONG Mode; 95 } FILE_MODE_INFORMATION, *PFILE_MODE_INFORMATION; 96 97 typedef struct _FILE_ALIGNMENT_INFORMATION { 98 ULONG AlignmentRequirement; 99 } FILE_ALIGNMENT_INFORMATION, *PFILE_ALIGNMENT_INFORMATION; 100 101 typedef struct _FILE_NAME_INFORMATION { 102 ULONG FileNameLength; 103 WCHAR FileName[1]; 104 } FILE_NAME_INFORMATION, *PFILE_NAME_INFORMATION; 105 106 typedef struct _FILE_ALL_INFORMATION { 107 FILE_BASIC_INFORMATION BasicInformation; 108 FILE_STANDARD_INFORMATION StandardInformation; 109 FILE_INTERNAL_INFORMATION InternalInformation; 110 FILE_EA_INFORMATION EaInformation; 111 FILE_ACCESS_INFORMATION AccessInformation; 112 FILE_POSITION_INFORMATION PositionInformation; 113 FILE_MODE_INFORMATION ModeInformation; 114 FILE_ALIGNMENT_INFORMATION AlignmentInformation; 115 FILE_NAME_INFORMATION NameInformation; 116 } FILE_ALL_INFORMATION, *PFILE_ALL_INFORMATION; 117 118 typedef enum _FILE_INFORMATION_CLASS { 119 FileDirectoryInformation = 1, 120 FileFullDirectoryInformation, 121 FileBothDirectoryInformation, 122 FileBasicInformation, 123 FileStandardInformation, 124 FileInternalInformation, 125 FileEaInformation, 126 FileAccessInformation, 127 FileNameInformation, 128 FileRenameInformation, 129 FileLinkInformation, 130 FileNamesInformation, 131 FileDispositionInformation, 132 FilePositionInformation, 133 FileFullEaInformation, 134 FileModeInformation, 135 FileAlignmentInformation, 136 FileAllInformation, 137 FileAllocationInformation, 138 FileEndOfFileInformation, 139 FileAlternateNameInformation, 140 FileStreamInformation, 141 FilePipeInformation, 142 FilePipeLocalInformation, 143 FilePipeRemoteInformation, 144 FileMailslotQueryInformation, 145 FileMailslotSetInformation, 146 FileCompressionInformation, 147 FileObjectIdInformation, 148 FileCompletionInformation, 149 FileMoveClusterInformation, 150 FileQuotaInformation, 151 FileReparsePointInformation, 152 FileNetworkOpenInformation, 153 FileAttributeTagInformation, 154 FileTrackingInformation, 155 FileIdBothDirectoryInformation, 156 FileIdFullDirectoryInformation, 157 FileValidDataLengthInformation, 158 FileShortNameInformation, 159 FileIoCompletionNotificationInformation, 160 FileIoStatusBlockRangeInformation, 161 FileIoPriorityHintInformation, 162 FileSfioReserveInformation, 163 FileSfioVolumeInformation, 164 FileHardLinkInformation, 165 FileProcessIdsUsingFileInformation, 166 FileNormalizedNameInformation, 167 FileNetworkPhysicalNameInformation, 168 FileIdGlobalTxDirectoryInformation, 169 FileIsRemoteDeviceInformation, 170 FileAttributeCacheInformation, 171 FileNumaNodeInformation, 172 FileStandardLinkInformation, 173 FileRemoteProtocolInformation, 174 FileMaximumInformation 175 } FILE_INFORMATION_CLASS, *PFILE_INFORMATION_CLASS; 176 177 #if !defined(OCAML_VERSION) || OCAML_VERSION < 40300 || OCAML_VERSION >= 41400 178 179 typedef struct _REPARSE_DATA_BUFFER { 180 ULONG ReparseTag; 181 USHORT ReparseDataLength; 182 USHORT Reserved; 183 union { 184 struct { 185 USHORT SubstituteNameOffset; 186 USHORT SubstituteNameLength; 187 USHORT PrintNameOffset; 188 USHORT PrintNameLength; 189 ULONG Flags; 190 WCHAR PathBuffer[1]; 191 } SymbolicLinkReparseBuffer; 192 struct { 193 USHORT SubstituteNameOffset; 194 USHORT SubstituteNameLength; 195 USHORT PrintNameOffset; 196 USHORT PrintNameLength; 197 WCHAR PathBuffer[1]; 198 } MountPointReparseBuffer; 199 struct { 200 UCHAR DataBuffer[1]; 201 } GenericReparseBuffer; 202 struct { 203 ULONG StringCount; 204 WCHAR StringList[1]; 205 } AppExecLinkReparseBuffer; 206 }; 207 } REPARSE_DATA_BUFFER, *PREPARSE_DATA_BUFFER; 208 209 #endif /* !OCAML_VERSION */ 210 211 typedef NTSTATUS (NTAPI *sNtQueryInformationFile) 212 (HANDLE FileHandle, 213 PIO_STATUS_BLOCK IoStatusBlock, 214 PVOID FileInformation, 215 ULONG Length, 216 FILE_INFORMATION_CLASS FileInformationClass); 217 218 typedef ULONG (NTAPI *sRtlNtStatusToDosError) 219 (NTSTATUS Status); 220 221 sNtQueryInformationFile pNtQueryInformationFile; 222 223 sRtlNtStatusToDosError pRtlNtStatusToDosError; 224 225 #ifndef NT_ERROR 226 #define NT_ERROR(status) ((((ULONG) (status)) >> 30) == 3) 227 #endif 228 229 /* END section originally copied from libuv win/winapi.h */ 230 231 static int nt_init_done = 0; 232 static int nt_api_available = 0; 233 234 /* BEGIN section originally copied from libuv win/winapi.c */ 235 236 void win_init() 237 { 238 HMODULE ntdll_module; 239 240 if (nt_init_done) return; 241 242 nt_init_done = 1; 243 244 ntdll_module = GetModuleHandleA("ntdll.dll"); 245 if (ntdll_module == NULL) { 246 nt_api_available = 0; 247 return; 248 } 249 250 pNtQueryInformationFile = (sNtQueryInformationFile) GetProcAddress( 251 ntdll_module, "NtQueryInformationFile"); 252 if (pNtQueryInformationFile == NULL) { 253 nt_api_available = 0; 254 return; 255 } 256 257 pRtlNtStatusToDosError = (sRtlNtStatusToDosError) GetProcAddress( 258 ntdll_module, "RtlNtStatusToDosError"); 259 if (pRtlNtStatusToDosError == NULL) { 260 nt_api_available = 0; 261 return; 262 } 263 264 nt_api_available = 1; 265 } 266 267 /* END section originally copied from libuv win/winapi.c */ 268 269 CAMLprim value win_has_correct_ctime(value unit) 270 { 271 CAMLparam0(); 272 273 win_init(); 274 275 CAMLreturn (nt_api_available ? Val_true : Val_false); 276 } 277 278 #define MAKEDWORDLONG(a,b) ((DWORDLONG)(((DWORD)(a))|(((DWORDLONG)((DWORD)(b)))<<32))) 279 #define WINTIME_TO_TIME(t) ((((ULONGLONG) t) - 116444736000000000ull) / 10000000ull) 280 #define FILETIME_TO_TIME(ft) WINTIME_TO_TIME((((ULONGLONG) ft.dwHighDateTime) << 32) + ft.dwLowDateTime) 281 #define FILETIME_NT_TO_TIME(ft) WINTIME_TO_TIME(ft.QuadPart) 282 283 CAMLprim value win_stat(value path, value lstat) 284 { 285 uintnat dev; 286 uintnat ino; 287 uintnat kind; 288 uintnat mode; 289 uintnat nlink; 290 uint64_t size = 0; 291 double atime; 292 double mtime; 293 double ctime; 294 int syml = 0; 295 296 int res; 297 NTSTATUS nt_status; 298 HANDLE h; 299 BY_HANDLE_FILE_INFORMATION info; 300 IO_STATUS_BLOCK io_status; 301 FILE_ALL_INFORMATION file_info; 302 CAMLparam2(path, lstat); 303 CAMLlocal1 (v); 304 char *fname = Bool_val(lstat) ? "lstat" : "stat"; 305 306 win_init(); 307 308 wchar_t *wpath = caml_stat_strdup_to_utf16(String_val(path)); 309 310 h = CreateFileW (wpath, FILE_READ_ATTRIBUTES, 311 FILE_SHARE_DELETE | FILE_SHARE_READ | FILE_SHARE_WRITE, 312 NULL, OPEN_EXISTING, 313 FILE_FLAG_BACKUP_SEMANTICS | FILE_ATTRIBUTE_READONLY | 314 (Bool_val(lstat) ? FILE_FLAG_OPEN_REPARSE_POINT : 0), NULL); 315 caml_stat_free(wpath); 316 317 if (h == INVALID_HANDLE_VALUE) { 318 caml_win32_maperr(GetLastError()); 319 caml_uerror(fname, path); 320 } 321 322 if (nt_api_available) { 323 nt_status = pNtQueryInformationFile(h, &io_status, &file_info, 324 sizeof file_info, FileAllInformation); 325 326 /* Buffer overflow (a warning status code) is expected here. */ 327 if (NT_ERROR(nt_status)) { 328 caml_win32_maperr(pRtlNtStatusToDosError(nt_status)); 329 (void) CloseHandle(h); 330 caml_uerror(fname, path); 331 } 332 } 333 334 res = GetFileInformationByHandle (h, &info); 335 if (res == 0) { 336 caml_win32_maperr(GetLastError()); 337 (void) CloseHandle (h); 338 caml_uerror(fname, path); 339 } 340 341 if (Bool_val(lstat) && 342 (info.dwFileAttributes & FILE_ATTRIBUTE_REPARSE_POINT)) { 343 /* The following code is partially copied from OCaml sources, 344 * LGPL 2.1, 345 * Copyright David Allsopp, MetaStack Solutions Ltd. */ 346 char buffer[16384]; 347 DWORD read; 348 349 if (DeviceIoControl(h, FSCTL_GET_REPARSE_POINT, NULL, 0, buffer, 16384, &read, NULL)) { 350 if (((REPARSE_DATA_BUFFER*)buffer)->ReparseTag == IO_REPARSE_TAG_SYMLINK) { 351 syml = 1; 352 size = ((REPARSE_DATA_BUFFER*)buffer)->SymbolicLinkReparseBuffer.SubstituteNameLength / 2; 353 } 354 } 355 } 356 357 res = CloseHandle (h); 358 if (res == 0) { 359 caml_win32_maperr(GetLastError()); 360 caml_uerror(fname, path); 361 } 362 363 if (Bool_val(lstat) && !syml) { 364 CAMLreturn(win_stat(path, Val_false)); 365 } 366 367 dev = info.dwVolumeSerialNumber; 368 369 if (nt_api_available) { 370 /* Use the same hashing formula as the original code */ 371 ino = ((DWORDLONG)file_info.InternalInformation.IndexNumber.QuadPart) + 372 155825701*((DWORDLONG)file_info.InternalInformation.IndexNumber.HighPart); 373 374 kind = file_info.BasicInformation.FileAttributes & FILE_ATTRIBUTE_DIRECTORY ? 1: 0; 375 376 mode = 0000444; 377 if (!(file_info.BasicInformation.FileAttributes & FILE_ATTRIBUTE_READONLY)) 378 mode |= 0000222; 379 if (file_info.BasicInformation.FileAttributes & FILE_ATTRIBUTE_DIRECTORY) 380 mode |= 0000111; 381 382 nlink = file_info.StandardInformation.NumberOfLinks; 383 if (!syml) { 384 size = file_info.StandardInformation.EndOfFile.QuadPart; 385 } 386 atime = (double) FILETIME_NT_TO_TIME(file_info.BasicInformation.LastAccessTime); 387 mtime = (double) FILETIME_NT_TO_TIME(file_info.BasicInformation.LastWriteTime); 388 if (file_info.BasicInformation.ChangeTime.QuadPart != 0) { 389 ctime = (double) FILETIME_NT_TO_TIME(file_info.BasicInformation.ChangeTime); 390 } else { 391 ctime = (double) FILETIME_NT_TO_TIME(file_info.BasicInformation.CreationTime); 392 } 393 } else { 394 // Apparently, we cannot trust the inode number to be stable when 395 // nFileIndexHigh is 0. 396 if (info.nFileIndexHigh == 0) info.nFileIndexLow = 0; 397 /* The ocaml code truncates inode numbers to 31 bits. We hash the 398 low and high parts in order to lose as little information as 399 possible. */ 400 ino = MAKEDWORDLONG(info.nFileIndexLow,info.nFileIndexHigh)+155825701*((DWORDLONG)info.nFileIndexHigh); 401 402 kind = info.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY ? 1: 0; 403 404 mode = 0000444; 405 if (info.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) 406 mode |= 0000111; 407 if (!(info.dwFileAttributes & FILE_ATTRIBUTE_READONLY)) 408 mode |= 0000222; 409 410 nlink = info.nNumberOfLinks; 411 if (!syml) { 412 size = MAKEDWORDLONG(info.nFileSizeLow,info.nFileSizeHigh); 413 } 414 atime = (double) FILETIME_TO_TIME(info.ftLastAccessTime); 415 mtime = (double) FILETIME_TO_TIME(info.ftLastWriteTime); 416 ctime = (double) FILETIME_TO_TIME(info.ftCreationTime); 417 } 418 419 if (syml) { 420 kind = 4; 421 mode |= 0000111 | 0000444; 422 } 423 424 v = caml_alloc (12, 0); 425 Store_field(v, 0, Val_int(dev)); 426 Store_field(v, 1, Val_int(ino)); 427 Store_field(v, 2, Val_int(kind)); 428 Store_field(v, 3, Val_int(mode)); 429 Store_field(v, 4, Val_int(nlink)); 430 Store_field(v, 5, Val_int(0)); 431 Store_field(v, 6, Val_int(0)); 432 Store_field(v, 7, Val_int(0)); 433 Store_field(v, 8, caml_copy_int64(size)); 434 Store_field(v, 9, caml_copy_double(atime)); 435 Store_field(v, 10, caml_copy_double(mtime)); 436 Store_field(v, 11, caml_copy_double(ctime)); 437 438 CAMLreturn (v); 439 } 440 441 /****/ 442 443 static value win_hasconsole_gui_msg(DWORD h, const char *s) 444 { 445 const char *u = "This is a GUI-only executable. Text console output " 446 "is not supported. To get text output, use the " 447 "executable intended for it (usually called unison.exe " 448 "or unison-text.exe) or redirect the output."; 449 450 if (!GetFileType((HANDLE) GetStdHandle(h))) { 451 MessageBoxA(NULL, strcmp(s, "") != 0 ? s : u, "Information", MB_OK); 452 return Val_false; 453 } else { 454 return Val_true; 455 } 456 } 457 458 CAMLprim value win_hasconsole_gui_stdout(value s) 459 { 460 CAMLparam1(s); 461 CAMLreturn(win_hasconsole_gui_msg(STD_OUTPUT_HANDLE, String_val(s))); 462 } 463 464 CAMLprim value win_hasconsole_gui_stderr(value s) 465 { 466 CAMLparam1(s); 467 CAMLreturn(win_hasconsole_gui_msg(STD_ERROR_HANDLE, String_val(s))); 468 } 469 470 CAMLprim value win_init_console(value unit) 471 { 472 CAMLparam0(); 473 CAMLlocal2(ret, tmp); 474 HANDLE in, out, err, in_orig, out_orig, err_orig; 475 FILE *ign; 476 477 ret = caml_alloc_tuple(3); 478 Store_field(ret, 0, Val_int(0)); 479 Store_field(ret, 1, Val_int(0)); 480 Store_field(ret, 2, Val_int(0)); 481 482 in_orig = (HANDLE) GetStdHandle(STD_INPUT_HANDLE); 483 out_orig = (HANDLE) GetStdHandle(STD_OUTPUT_HANDLE); 484 err_orig = (HANDLE) GetStdHandle(STD_ERROR_HANDLE); 485 486 /* What is going on here... Due to what is arguably a bug in Windows, when 487 * stdout and stderr share the same fd/handle inherited by the process, only 488 * stdout is closed and cleared for GUI applications without console at 489 * process startup. This situation is not something that usually happens in 490 * Windows. It seems to happen only when an application is started by a 491 * Cygwin/MSYS2 shell (maybe further depending on in which context the shell 492 * itself is running). It may also happen when the parent process has marked 493 * the handle as not inheritable and then still instructs the child process 494 * to use this handle, which is clearly a bug in the parent. 495 * 496 * This is what happens when stdout and stderr share the same handle. 497 * 498 * For GUI applications without console (and without redirections) Windows 499 * closes and clears stdin, stdout and stderr handles at startup. Since 500 * stdout is closed first, stderr has become invalid and since it's invalid, 501 * Windows does not close and clear stderr. The handle still set as stderr 502 * value (remember, it is now actually closed and free for kernel to reuse) 503 * is then later given by kernel to whatever happens to require a new handle. 504 * 505 * The application has now started and has no idea that something's wrong. 506 * AllocConsole() sees that stderr already has a handle set and does not set 507 * a new handle for stderr (as it should for a newly allocated console). 508 * 509 * Now, when trying to use stderr in any way (writing to it, or doing 510 * dup/dup2), it may fail in unexpected ways or even cause corruption because 511 * the handle is invalid or it could have been reused for anything. In any 512 * case, it will likely lead to a crash. 513 * 514 * It's not possible to detect this situation completely reliably because by 515 * the time the application code runs, stdout has already been cleared and 516 * the stderr handle could have been reused for anything and our checks could 517 * be returning valid values (so it becomes indistinguishable from a 518 * redirected stderr). The only way we can detect if something like this is 519 * happening, is to check if stdout is cleared but stderr is not and stderr 520 * is invalid. Interestingly, at least newer versions of CRT (don't know 521 * about UCRT) get this right and correctly report both stdout and stderr as 522 * not set. We can leverage this to make the check that much more reliable. 523 * 524 * We only do this check for stderr because we don't otherwise expect to have 525 * invalid std handles which are not NULL. */ 526 if (err_orig && !out_orig 527 && ((!GetFileType(err_orig) && (ERROR_INVALID_HANDLE == GetLastError())) 528 || (_fileno(stderr) == -2))) { 529 SetStdHandle(STD_ERROR_HANDLE, NULL); 530 err_orig = NULL; 531 } 532 533 if (!GetFileType(out_orig) || !GetFileType(err_orig)) { 534 AllocConsole(); 535 /* There's nothing we can do about an error, so we're not going to check. 536 * Already having a console returns an error, which we want to ignore. */ 537 if (GetStdHandle(STD_ERROR_HANDLE) == NULL) { 538 MessageBoxW(NULL, L"Unable to open a console where debugging output " 539 "will be sent. The program will most likely crash " 540 "when trying to produce debugging output.\n\n" 541 "If the problem persists then remove any \"debug\" " 542 "preferences from the profile, use the text UI or " 543 "redirect standard output and error.", 544 L"Error", MB_OK | MB_ICONWARNING); 545 } 546 547 /* Windows C runtime fds for stdin, stdout, stderr are not restored 548 * automatically. */ 549 if (_fileno(stdin) < 0) freopen_s(&ign, "CONIN$", "r", stdin); 550 if (_fileno(stdout) < 0) freopen_s(&ign, "CONOUT$", "w", stdout); 551 if (_fileno(stderr) < 0) freopen_s(&ign, "CONOUT$", "w", stderr); 552 553 /* AllocConsole() is supposed to init these handles. */ 554 in = (HANDLE) GetStdHandle(STD_INPUT_HANDLE); 555 out = (HANDLE) GetStdHandle(STD_OUTPUT_HANDLE); 556 err = (HANDLE) GetStdHandle(STD_ERROR_HANDLE); 557 558 /* Return only handles that are not already redirected by user. */ 559 if (!GetFileType(in_orig) && (in != in_orig)) { 560 tmp = caml_alloc(1, 0); 561 Store_field(tmp, 0, caml_win32_alloc_handle(in)); 562 Store_field(ret, 0, tmp); 563 } 564 if (!GetFileType(out_orig) && (out != out_orig)) { 565 tmp = caml_alloc(1, 0); 566 Store_field(tmp, 0, caml_win32_alloc_handle(out)); 567 Store_field(ret, 1, tmp); 568 } 569 if (!GetFileType(err_orig) && (err != err_orig)) { 570 tmp = caml_alloc(1, 0); 571 Store_field(tmp, 0, caml_win32_alloc_handle(err)); 572 Store_field(ret, 2, tmp); 573 } 574 } 575 576 CAMLreturn(ret); 577 } 578 579 static HANDLE conin = INVALID_HANDLE_VALUE; 580 581 static void init_conin () 582 { 583 if (conin == INVALID_HANDLE_VALUE) { 584 conin = CreateFile ("CONIN$", GENERIC_READ | GENERIC_WRITE, 585 FILE_SHARE_READ | FILE_SHARE_WRITE, NULL, 586 OPEN_EXISTING, 0, 0); 587 if (conin == INVALID_HANDLE_VALUE) { 588 caml_win32_maperr(GetLastError()); 589 caml_uerror("init_conin", Nothing); 590 } 591 } 592 } 593 594 CAMLprim value win_get_console_mode (value unit) 595 { 596 CAMLparam0(); 597 DWORD mode; 598 BOOL res; 599 600 init_conin (); 601 602 res = GetConsoleMode (conin, &mode); 603 if (res == 0) { 604 caml_win32_maperr(GetLastError()); 605 caml_uerror("get_console_mode", Nothing); 606 } 607 608 CAMLreturn(Val_int(mode)); 609 } 610 611 CAMLprim value win_set_console_mode (value mode) 612 { 613 CAMLparam1(mode); 614 BOOL res; 615 616 init_conin (); 617 618 res = SetConsoleMode (conin, Int_val(mode)); 619 if (res == 0) { 620 caml_win32_maperr(GetLastError()); 621 caml_uerror("set_console_mode", Nothing); 622 } 623 CAMLreturn(Val_unit); 624 } 625 626 CAMLprim value win_get_console_output_cp (value unit) { 627 CAMLparam0(); 628 CAMLreturn(Val_int(GetConsoleOutputCP())); 629 } 630 631 CAMLprim value win_set_console_output_cp (value cp) { 632 CAMLparam1(cp); 633 BOOL res; 634 res = SetConsoleOutputCP (Int_val (cp)); 635 if (res == 0) { 636 caml_win32_maperr(GetLastError()); 637 caml_uerror("set_console_cp", Nothing); 638 } 639 CAMLreturn(Val_unit); 640 } 641 642 CAMLprim value win_vt_capable(value fd) 643 { 644 CAMLparam1(fd); 645 DWORD mode; 646 647 if (Handle_val(fd) == INVALID_HANDLE_VALUE) { 648 CAMLreturn(Val_int(0)); 649 } 650 651 if (!GetConsoleMode(Handle_val(fd), &mode)) { 652 CAMLreturn(Val_int(0)); 653 } 654 655 CAMLreturn(Val_int(mode & ENABLE_VIRTUAL_TERMINAL_PROCESSING)); 656 }