/**************************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. */ /* */ /* All rights reserved. This file is distributed under the terms of */ /* the GNU Lesser General Public License version 2.1, with the */ /* special exception on linking described in the file LICENSE. */ /* */ /**************************************************************************/ #define CAML_INTERNALS /* Win32-specific stuff */ /* FILE_INFO_BY_HANDLE_CLASS and FILE_NAME_INFO are only available from Windows Vista onwards */ #undef _WIN32_WINNT #define _WIN32_WINNT 0x0600 #define WIN32_LEAN_AND_MEAN #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include "caml/alloc.h" #include "caml/codefrag.h" #include "caml/fail.h" #include "caml/io.h" #include "caml/memory.h" #include "caml/misc.h" #include "caml/osdeps.h" #include "caml/signals.h" #include "caml/sys.h" #include "caml/winsupport.h" #include "caml/startup_aux.h" #include "caml/platform.h" #include "caml/config.h" #if defined(SUPPORT_DYNAMIC_LINKING) && !defined(BUILDING_LIBCAMLRUNS) #define WITH_DYNAMIC_LINKING #endif #ifdef WITH_DYNAMIC_LINKING #include #endif #ifndef S_ISREG #define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG) #endif unsigned short caml_win32_major = 0; unsigned short caml_win32_minor = 0; unsigned short caml_win32_build = 0; unsigned short caml_win32_revision = 0; CAMLnoret static void caml_win32_sys_error(int errnum) { wchar_t buffer[512]; value msg; if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS, NULL, errnum, 0, buffer, sizeof(buffer)/sizeof(wchar_t), NULL)) { msg = caml_copy_string_of_utf16(buffer); } else { msg = caml_alloc_sprintf("unknown error #%d", errnum); } caml_raise_sys_error(msg); } int caml_read_fd(int fd, int flags, void * buf, int n) { int retcode; caml_enter_blocking_section_no_pending(); if ((flags & CHANNEL_FLAG_FROM_SOCKET) == 0) { retcode = read(fd, buf, n); /* Large reads from console can fail with ENOMEM. Reduce requested size and try again. */ if (retcode == -1 && errno == ENOMEM && n > 16384) { retcode = read(fd, buf, 16384); } } else { retcode = recv((SOCKET) _get_osfhandle(fd), buf, n, 0); if (retcode == -1) { errno = caml_posixerr_of_win32err(WSAGetLastError()); if (errno == 0) errno = EINVAL; } } caml_leave_blocking_section(); return retcode; } int caml_write_fd(int fd, int flags, void * buf, int n) { int retcode; caml_enter_blocking_section_no_pending(); if ((flags & CHANNEL_FLAG_FROM_SOCKET) == 0) { retcode = write(fd, buf, n); } else { retcode = send((SOCKET) _get_osfhandle(fd), buf, n, 0); if (retcode == -1) { errno = caml_posixerr_of_win32err(WSAGetLastError()); if (errno == 0) errno = EINVAL; } } caml_leave_blocking_section(); CAMLassert (retcode > 0 || retcode == -1); return retcode; } wchar_t * caml_decompose_path(struct ext_table * tbl, wchar_t * path) { wchar_t * p, * q; int n; if (path == NULL) return NULL; p = caml_stat_wcsdup(path); q = p; while (1) { for (n = 0; q[n] != 0 && q[n] != L';'; n++) /*nothing*/; caml_ext_table_add(tbl, q); q = q + n; if (*q == 0) break; *q = 0; q += 1; } return p; } wchar_t * caml_search_in_path(struct ext_table * path, const wchar_t * name) { wchar_t * dir, * fullname; char * u8; struct _stati64 st; for (const wchar_t *p = name; *p != 0; p++) { if (*p == '/' || *p == '\\') goto not_found; } for (int i = 0; i < path->size; i++) { dir = path->contents[i]; if (dir[0] == 0) continue; /* not sure what empty path components mean under Windows */ fullname = caml_stat_wcsconcat(3, dir, L"\\", name); u8 = caml_stat_strdup_of_utf16(fullname); caml_gc_message(0x100, "Searching %s\n", u8); caml_stat_free(u8); if (_wstati64(fullname, &st) == 0 && S_ISREG(st.st_mode)) return fullname; caml_stat_free(fullname); } not_found: u8 = caml_stat_strdup_of_utf16(name); caml_gc_message(0x100, "%s not found in search path\n", u8); caml_stat_free(u8); return caml_stat_wcsdup(name); } CAMLexport wchar_t * caml_search_exe_in_path(const wchar_t * name) { wchar_t * fullname, * filepart; char * u8; size_t fullnamelen; DWORD retcode; fullnamelen = wcslen(name) + 1; if (fullnamelen < 256) fullnamelen = 256; while (1) { fullname = caml_stat_alloc(fullnamelen*sizeof(wchar_t)); retcode = SearchPath(NULL, /* use system search path */ name, L".exe", /* add .exe extension if needed */ fullnamelen, fullname, &filepart); if (retcode == 0) { u8 = caml_stat_strdup_of_utf16(name); caml_gc_message(0x100, "%s not found in search path\n", u8); caml_stat_free(u8); caml_stat_free(fullname); return caml_stat_strdup_os(name); } if (retcode < fullnamelen) return fullname; caml_stat_free(fullname); fullnamelen = retcode + 1; } } wchar_t * caml_search_dll_in_path(struct ext_table * path, const wchar_t * name) { wchar_t * dllname; wchar_t * res; dllname = caml_stat_wcsconcat(2, name, L".dll"); res = caml_search_in_path(path, dllname); caml_stat_free(dllname); return res; } #ifdef WITH_DYNAMIC_LINKING void * caml_dlopen(wchar_t * libname, int global) { void *handle; int flags = (global ? FLEXDLL_RTLD_GLOBAL : 0); handle = flexdll_wdlopen(libname, flags); if ((handle != NULL) && ((atomic_load_relaxed(&caml_verb_gc) & 0x100) != 0)) { flexdll_dump_exports(handle); fflush(stdout); } return handle; } void caml_dlclose(void * handle) { flexdll_dlclose(handle); } void * caml_dlsym(void * handle, const char * name) { return flexdll_dlsym(handle, name); } void * caml_globalsym(const char * name) { return flexdll_dlsym(flexdll_wdlopen(NULL,0), name); } char * caml_dlerror(void) { return flexdll_dlerror(); } #else void * caml_dlopen(wchar_t * libname, int global) { return NULL; } void caml_dlclose(void * handle) { } void * caml_dlsym(void * handle, const char * name) { return NULL; } void * caml_globalsym(const char * name) { return NULL; } char * caml_dlerror(void) { return "dynamic loading not supported on this platform"; } #endif /* WITH_DYNAMIC_LINKING */ /* Proper emulation of signal(), including ctrl-C and ctrl-break */ typedef void (*sighandler)(int sig); static int ctrl_handler_installed = 0; static volatile sighandler ctrl_handler_action = SIG_DFL; static BOOL WINAPI ctrl_handler(DWORD event) { /* Only ctrl-C and ctrl-Break are handled */ if (event != CTRL_C_EVENT && event != CTRL_BREAK_EVENT) return FALSE; /* Default behavior is to exit, which we get by not handling the event */ if (ctrl_handler_action == SIG_DFL) return FALSE; /* Ignore behavior is to do nothing, which we get by claiming that we have handled the event */ if (ctrl_handler_action == SIG_IGN) return TRUE; /* Win32 doesn't like it when we do a longjmp() at this point (it looks like we're running in a different thread than the main program!). So, just record the signal. */ caml_record_signal(SIGINT); /* We have handled the event */ return TRUE; } sighandler caml_win32_signal(int sig, sighandler action) { sighandler oldaction; if (sig != SIGINT) return signal(sig, action); if (! ctrl_handler_installed) { SetConsoleCtrlHandler(ctrl_handler, TRUE); ctrl_handler_installed = 1; } oldaction = ctrl_handler_action; ctrl_handler_action = action; return oldaction; } /* Expansion of @responsefile and *? file patterns in the command line */ static int argc; static wchar_t ** argv; static int argvsize; static void store_argument(wchar_t * arg); static void expand_argument(wchar_t * arg); static void expand_pattern(wchar_t * arg); static void out_of_memory(void) { caml_fatal_error("out of memory while expanding command line"); } static void store_argument(wchar_t * arg) { if (argc + 1 >= argvsize) { argvsize *= 2; argv = (wchar_t **) caml_stat_resize_noexc(argv, argvsize * sizeof(wchar_t *)); if (argv == NULL) out_of_memory(); } argv[argc++] = arg; } static void expand_argument(wchar_t * arg) { for (wchar_t *p = arg; *p != 0; p++) { if (*p == L'*' || *p == L'?') { expand_pattern(arg); return; } } store_argument(arg); } static void expand_pattern(wchar_t * pat) { wchar_t * prefix, * name; intptr_t handle; struct _wfinddata_t ffblk; size_t i; handle = _wfindfirst(pat, &ffblk); if (handle == -1) { store_argument(pat); /* a la Bourne shell */ return; } prefix = caml_stat_wcsdup(pat); /* We need to stop at the first directory or drive boundary, because the * _findata_t structure contains the filename, not the leading directory. */ for (i = wcslen(prefix); i > 0; i--) { wchar_t c = prefix[i - 1]; if (c == L'\\' || c == L'/' || c == L':') { prefix[i] = 0; break; } } /* No separator was found, it's a filename pattern without a leading directory. */ if (i == 0) prefix[0] = 0; do { name = caml_stat_wcsconcat(2, prefix, ffblk.name); store_argument(name); } while (_wfindnext(handle, &ffblk) != -1); _findclose(handle); caml_stat_free(prefix); } CAMLexport void caml_expand_command_line(int * argcp, wchar_t *** argvp) { argc = 0; argvsize = 16; argv = (wchar_t **) caml_stat_alloc_noexc(argvsize * sizeof(wchar_t *)); if (argv == NULL) out_of_memory(); for (int i = 0; i < *argcp; i++) expand_argument((*argvp)[i]); argv[argc] = NULL; *argcp = argc; *argvp = argv; } /* Add to [contents] the (short) names of the files contained in the directory named [dirname]. No entries are added for [.] and [..]. Return 0 on success, -1 on error; set errno in the case of error. */ CAMLexport int caml_read_directory(wchar_t * dirname, struct ext_table * contents) { size_t dirnamelen; wchar_t * template; intptr_t h; struct _wfinddata_t fileinfo; int res; dirnamelen = wcslen(dirname); if (dirnamelen > 0 && (dirname[dirnamelen - 1] == L'/' || dirname[dirnamelen - 1] == L'\\' || dirname[dirnamelen - 1] == L':')) template = caml_stat_wcsconcat(2, dirname, L"*.*"); else { template = caml_stat_wcsconcat(2, dirname, L"\\*.*"); dirnamelen++; /* template[dirnamelen] always points after the backslash */ } h = _wfindfirst(template, &fileinfo); if (h == -1) { /* Instead of checking the existence of [dirname] directly, we call [GetFileAttributes()] on [template] without the trailing [*.*]. The added backslash at the end gives us the expected result (-1) on pathological paths like [...]. */ template[dirnamelen] = L'\0'; res = errno == ENOENT && GetFileAttributes(template) != INVALID_FILE_ATTRIBUTES ? 0 : -1; caml_stat_free(template); return res; } do { if (wcscmp(fileinfo.name, L".") != 0 && wcscmp(fileinfo.name, L"..") != 0) { res = caml_ext_table_add_noexc(contents, caml_stat_strdup_of_utf16(fileinfo.name)); if (res == -1) { _findclose(h); errno = ENOMEM; return -1; } } } while (_wfindnext(h, &fileinfo) == 0); _findclose(h); caml_stat_free(template); return 0; } #ifndef NATIVE_CODE /* Set up a new thread for control-C emulation and termination */ void caml_signal_thread(void * lpParam) { wchar_t *endptr; HANDLE h; /* Get an hexa-code raw handle through the environment */ h = (HANDLE) (uintptr_t) wcstol(caml_secure_getenv(T("CAMLSIGPIPE")), &endptr, 16); while (1) { DWORD numread; BOOL ret; char iobuf[2]; /* This shall always return a single character */ ret = ReadFile(h, iobuf, 1, &numread, NULL); if (!ret || numread != 1) caml_do_exit(2); switch (iobuf[0]) { case 'C': caml_record_signal(SIGINT); break; case 'T': raise(SIGTERM); return; } } } #endif /* NATIVE_CODE */ #if defined(NATIVE_CODE) /* Handling of system stack overflow. * Based on code provided by Olivier Andrieu. * An EXCEPTION_STACK_OVERFLOW is signaled when the guard page at the * end of the stack has been accessed. Windows clears the PAGE_GUARD * protection (making it a regular PAGE_READWRITE) and then calls our * exception handler. This means that although we're handling an "out * of stack" condition, there is a bit of stack available to call * functions and allocate temporaries. * * PAGE_GUARD is a one-shot access protection mechanism: we need to * restore the PAGE_GUARD protection on this page otherwise the next * stack overflow won't be detected and the program will abruptly exit * with STATUS_ACCESS_VIOLATION. * * Visual Studio 2003 and later (_MSC_VER >= 1300) have a * _resetstkoflw() function that resets this protection. * Unfortunately, it cannot work when called directly from the * exception handler because at this point we are using the page that * is to be protected. * * A solution is to use an alternate stack when restoring the * protection. However it's not possible to use _resetstkoflw() then * since it determines the stack pointer by calling alloca(): it would * try to protect the alternate stack. * * Finally, we call caml_raise_stack_overflow; it will either call * caml_raise_exception which switches back to the normal stack, or * call caml_fatal_uncaught_exception which terminates the program * quickly. */ static uintnat win32_alt_stack[0x100]; static void caml_reset_stack (void *faulting_address) { SYSTEM_INFO si; DWORD page_size; MEMORY_BASIC_INFORMATION mbi; DWORD oldprot; /* get the system's page size. */ GetSystemInfo (&si); page_size = si.dwPageSize; /* get some information on the page the fault occurred */ if (! VirtualQuery (faulting_address, &mbi, sizeof mbi)) goto failed; VirtualProtect (mbi.BaseAddress, page_size, mbi.Protect | PAGE_GUARD, &oldprot); failed: caml_raise_stack_overflow(); } #ifndef _WIN64 static LONG CALLBACK caml_stack_overflow_VEH (EXCEPTION_POINTERS* exn_info) { DWORD code = exn_info->ExceptionRecord->ExceptionCode; CONTEXT *ctx = exn_info->ContextRecord; DWORD *ctx_ip = &(ctx->Eip); DWORD *ctx_sp = &(ctx->Esp); if (code == EXCEPTION_STACK_OVERFLOW && caml_find_code_fragment_by_pc((char *) (*ctx_ip)) != NULL) { uintnat faulting_address; uintnat * alt_esp; /* grab the address that caused the fault */ faulting_address = exn_info->ExceptionRecord->ExceptionInformation[1]; /* call caml_reset_stack(faulting_address) using the alternate stack */ alt_esp = win32_alt_stack + sizeof(win32_alt_stack) / sizeof(uintnat); *--alt_esp = faulting_address; *ctx_sp = (uintnat) (alt_esp - 1); *ctx_ip = (uintnat) &caml_reset_stack; return EXCEPTION_CONTINUE_EXECUTION; } return EXCEPTION_CONTINUE_SEARCH; } #else static LONG CALLBACK caml_stack_overflow_VEH (EXCEPTION_POINTERS* exn_info) { DWORD code = exn_info->ExceptionRecord->ExceptionCode; CONTEXT *ctx = exn_info->ContextRecord; if (code == EXCEPTION_STACK_OVERFLOW && caml_find_code_fragment_by_pc((char *) (ctx->Rip)) != NULL) { uintnat faulting_address; uintnat * alt_rsp; /* grab the address that caused the fault */ faulting_address = exn_info->ExceptionRecord->ExceptionInformation[1]; /* refresh runtime parameters from registers */ Caml_state->young_ptr = (value *) ctx->R15; /* call caml_reset_stack(faulting_address) using the alternate stack */ alt_rsp = win32_alt_stack + sizeof(win32_alt_stack) / sizeof(uintnat); ctx->Rcx = faulting_address; ctx->Rsp = (uintnat) (alt_rsp - 4 - 1); ctx->Rip = (uintnat) &caml_reset_stack; return EXCEPTION_CONTINUE_EXECUTION; } return EXCEPTION_CONTINUE_SEARCH; } #endif /* _WIN64 */ static PVOID caml_stack_overflow_handle; void caml_win32_overflow_detection(void) { caml_stack_overflow_handle = AddVectoredExceptionHandler(1, caml_stack_overflow_VEH); if (caml_stack_overflow_handle == NULL) { caml_fatal_error("cannot install stack overflow detection"); } } void caml_win32_unregister_overflow_detection(void) { RemoveVectoredExceptionHandler(caml_stack_overflow_handle); } #endif /* NATIVE_CODE */ /* Seeding of pseudo-random number generators */ int caml_win32_random_seed (intnat data[16]) { /* For better randomness, consider: http://msdn.microsoft.com/library/en-us/seccrypto/security/rtlgenrandom.asp http://blogs.msdn.com/b/michael_howard/archive/2005/01/14/353379.aspx */ FILETIME t; LARGE_INTEGER pc; GetSystemTimeAsFileTime(&t); QueryPerformanceCounter(&pc); /* PR#6032 */ data[0] = t.dwLowDateTime; data[1] = t.dwHighDateTime; data[2] = GetCurrentProcessId(); data[3] = pc.LowPart; data[4] = pc.HighPart; return 5; } #ifdef _MSC_VER static void invalid_parameter_handler(const wchar_t* expression, const wchar_t* function, const wchar_t* file, unsigned int line, uintptr_t pReserved) { /* no crash box */ } void caml_install_invalid_parameter_handler(void) { _set_invalid_parameter_handler(invalid_parameter_handler); } #endif /* Recover executable name */ wchar_t * caml_executable_name(void) { wchar_t * name; DWORD namelen, ret; namelen = 256; while (1) { name = caml_stat_alloc(namelen*sizeof(wchar_t)); ret = GetModuleFileName(NULL, name, namelen); if (ret == 0) { caml_stat_free(name); return NULL; } if (ret < namelen) break; caml_stat_free(name); if (namelen >= 1024*1024) return NULL; /* avoid runaway and overflow */ namelen *= 2; } return name; } /* snprintf emulation */ #define CAML_SNPRINTF(_vsnprintf, _vscprintf) \ { \ int len; \ va_list args; \ \ if (size > 0) { \ va_start(args, format); \ len = _vsnprintf(buf, size, format, args); \ va_end(args); \ if (len >= 0 && len < size) { \ /* [len] characters were stored in [buf], \ a null-terminator was appended. */ \ return len; \ } \ /* [size] characters were stored in [buf], without null termination. \ Put a null terminator, truncating the output. */ \ buf[size - 1] = 0; \ } \ /* Compute the actual length of output, excluding null terminator */ \ va_start(args, format); \ len = _vscprintf(format, args); \ va_end(args); \ return len; \ } #ifndef _UCRT int caml_snprintf(char * buf, size_t size, const char * format, ...) CAML_SNPRINTF(_vsnprintf, _vscprintf) #endif int caml_snwprintf(wchar_t * buf, size_t size, const wchar_t * format, ...) CAML_SNPRINTF(_vsnwprintf, _vscwprintf) #undef CAML_SNPRINTF wchar_t *caml_secure_getenv (wchar_t const *var) { /* Win32 doesn't have a notion of setuid bit, so getenv is safe. */ return _wgetenv(var); } /* caml_win32_getenv is used to implement Sys.getenv and Unix.getenv in such a way that they get direct access to the Win32 environment rather than to the copy that is cached by the C runtime system. The result of caml_win32_getenv is dynamically allocated and must be explicitly deallocated. In contrast, the OCaml runtime system still calls _wgetenv from the C runtime system, via caml_secure_getenv. The result is statically allocated and needs no deallocation. */ CAMLexport wchar_t *caml_win32_getenv(wchar_t const *lpName) { wchar_t * lpBuffer; DWORD nSize = 256, res; lpBuffer = caml_stat_alloc_noexc(nSize * sizeof(wchar_t)); if (lpBuffer == NULL) return NULL; res = GetEnvironmentVariable(lpName, lpBuffer, nSize); if (res == 0) { caml_stat_free(lpBuffer); return NULL; } if (res < nSize) return lpBuffer; nSize = res; lpBuffer = caml_stat_resize_noexc(lpBuffer, nSize * sizeof(wchar_t)); if (lpBuffer == NULL) return NULL; res = GetEnvironmentVariable(lpName, lpBuffer, nSize); if (res == 0 || res >= nSize) { caml_stat_free(lpBuffer); return NULL; } return lpBuffer; } /* The rename() implementation in MSVC's CRT is based on MoveFile() and therefore fails if the new name exists. This is inconsistent with POSIX and a problem in practice. Here we reimplement rename() using MoveFileEx() to make it more POSIX-like. There are no official guarantee that the rename operation is atomic, but it is widely believed to be atomic on NTFS. */ int caml_win32_rename(const wchar_t * oldpath, const wchar_t * newpath) { /* First handle corner-case not handled by MoveFileEx: - dir to existing file - should fail */ DWORD new_attribs; DWORD old_attribs = GetFileAttributes(oldpath); if ((old_attribs != INVALID_FILE_ATTRIBUTES) && (old_attribs & FILE_ATTRIBUTE_DIRECTORY) != 0) { new_attribs = GetFileAttributes(newpath); if ((new_attribs != INVALID_FILE_ATTRIBUTES) && (new_attribs & FILE_ATTRIBUTE_DIRECTORY) == 0) { errno = ENOTDIR; return -1; } } /* MOVEFILE_REPLACE_EXISTING: to be closer to POSIX MOVEFILE_COPY_ALLOWED: MoveFile performs a copy if old and new paths are on different devices, so we do the same here for compatibility with the old rename()-based implementation. MOVEFILE_WRITE_THROUGH: not sure it's useful; affects only the case where a copy is done. */ if (MoveFileEx(oldpath, newpath, MOVEFILE_REPLACE_EXISTING | MOVEFILE_WRITE_THROUGH | MOVEFILE_COPY_ALLOWED)) { return 0; } /* Another cornercase not handled by MoveFileEx: - dir to empty dir - positive - should succeed */ if ((old_attribs != INVALID_FILE_ATTRIBUTES) && (old_attribs & FILE_ATTRIBUTE_DIRECTORY) != 0 && (new_attribs != INVALID_FILE_ATTRIBUTES) && (new_attribs & FILE_ATTRIBUTE_DIRECTORY) != 0 && !PathIsPrefix(oldpath, newpath)) { /* Try to delete: RemoveDirectoryW fails on non-empty dirs as intended. Then try again. */ RemoveDirectoryW(newpath); if (MoveFileEx(oldpath, newpath, MOVEFILE_REPLACE_EXISTING | MOVEFILE_WRITE_THROUGH | MOVEFILE_COPY_ALLOWED)) { return 0; } } errno = caml_posixerr_of_win32err(GetLastError()); if (errno == 0) errno = EINVAL; return -1; } int caml_win32_unlink(const wchar_t * path) { int ret; ret = _wunlink(path); /* On Windows, trying to unlink a symlink to a directory will return * EACCES, but the symlink can be deleted with rmdir. */ if (ret == -1 && errno == EACCES) { HANDLE h; DWORD attrs, dummy; union { char raw[16384]; REPARSE_DATA_BUFFER point; } buffer; attrs = GetFileAttributes(path); if (attrs == INVALID_FILE_ATTRIBUTES || !(attrs & (FILE_ATTRIBUTE_DIRECTORY | FILE_ATTRIBUTE_REPARSE_POINT))) return -1; h = CreateFile(path, FILE_READ_ATTRIBUTES, FILE_SHARE_DELETE | FILE_SHARE_READ | FILE_SHARE_WRITE, NULL, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT, NULL); if (h == INVALID_HANDLE_VALUE) return -1; ret = DeviceIoControl(h, FSCTL_GET_REPARSE_POINT, NULL, 0, &buffer.point, sizeof(buffer.raw), &dummy, NULL); CloseHandle(h); if (!ret || buffer.point.ReparseTag != IO_REPARSE_TAG_SYMLINK) return -1; ret = _wrmdir(path); if (ret == -1) errno = EACCES; } return ret; } /* Windows Unicode support */ static uintnat windows_unicode_enabled = WINDOWS_UNICODE; /* If [windows_unicode_strict] is non-zero, then illegal UTF-8 characters (on the OCaml side) or illegal UTF-16 characters (on the Windows side) cause an error to be signaled. What happens then depends on the variable [windows_unicode_fallback]. If [windows_unicode_strict] is zero, then illegal characters are silently dropped. */ static uintnat windows_unicode_strict = 1; /* If [windows_unicode_fallback] is non-zero, then if an error is signaled when translating to UTF-16, the translation is re-done under the assumption that the argument string is encoded in the local codepage. */ static uintnat windows_unicode_fallback = 1; CAMLexport int caml_win32_multi_byte_to_wide_char(const char *s, int slen, wchar_t *out, int outlen) { int retcode; CAMLassert (s != NULL); if (slen == 0) return 0; if (windows_unicode_enabled != 0) { retcode = MultiByteToWideChar(CP_UTF8, windows_unicode_strict ? MB_ERR_INVALID_CHARS : 0, s, slen, out, outlen); if (retcode == 0 && windows_unicode_fallback != 0) retcode = MultiByteToWideChar(CP_ACP, 0, s, slen, out, outlen); } else { retcode = MultiByteToWideChar(CP_ACP, 0, s, slen, out, outlen); } if (retcode == 0) caml_win32_sys_error(GetLastError()); return retcode; } /* For old versions of Windows we simply ignore the flag */ #ifndef WC_ERR_INVALID_CHARS #define WC_ERR_INVALID_CHARS 0 #endif CAMLexport int caml_win32_wide_char_to_multi_byte(const wchar_t *s, int slen, char *out, int outlen) { int retcode; CAMLassert(s != NULL); if (slen == 0) return 0; if (windows_unicode_enabled != 0) retcode = WideCharToMultiByte(CP_UTF8, windows_unicode_strict ? WC_ERR_INVALID_CHARS : 0, s, slen, out, outlen, NULL, NULL); else retcode = WideCharToMultiByte(CP_ACP, 0, s, slen, out, outlen, NULL, NULL); if (retcode == 0) caml_win32_sys_error(GetLastError()); return retcode; } CAMLexport value caml_copy_string_of_utf16(const wchar_t *s) { int retcode, slen; value v; slen = wcslen(s); /* Do not include final NULL */ retcode = caml_win32_wide_char_to_multi_byte(s, slen, NULL, 0); v = caml_alloc_string(retcode); caml_win32_wide_char_to_multi_byte(s, slen, (char *)String_val(v), retcode); return v; } CAMLexport wchar_t* caml_stat_strdup_to_utf16(const char *s) { wchar_t * ws; int retcode; retcode = caml_win32_multi_byte_to_wide_char(s, -1, NULL, 0); ws = caml_stat_alloc_noexc(retcode * sizeof(*ws)); caml_win32_multi_byte_to_wide_char(s, -1, ws, retcode); return ws; } CAMLexport caml_stat_string caml_stat_strdup_noexc_of_utf16(const wchar_t *s) { caml_stat_string out; int retcode; retcode = caml_win32_wide_char_to_multi_byte(s, -1, NULL, 0); out = caml_stat_alloc_noexc(retcode); if (out != NULL) { caml_win32_wide_char_to_multi_byte(s, -1, out, retcode); } return out; } CAMLexport caml_stat_string caml_stat_strdup_of_utf16(const wchar_t *s) { caml_stat_string out = caml_stat_strdup_noexc_of_utf16(s); if (out == NULL) caml_raise_out_of_memory(); return out; } void caml_probe_win32_version(void) { /* Determine the version of Windows we're running, and cache it */ WCHAR fileName[MAX_PATH]; DWORD size = GetModuleFileName(GetModuleHandle(L"kernel32"), fileName, MAX_PATH); DWORD dwHandle = 0; BYTE* versionInfo; fileName[size] = 0; size = GetFileVersionInfoSize(fileName, &dwHandle); versionInfo = (BYTE*)malloc(size * sizeof(BYTE)); if (GetFileVersionInfo(fileName, 0, size, versionInfo)) { UINT len = 0; VS_FIXEDFILEINFO* vsfi = NULL; VerQueryValue(versionInfo, L"\\", (void**)&vsfi, &len); caml_win32_major = HIWORD(vsfi->dwProductVersionMS); caml_win32_minor = LOWORD(vsfi->dwProductVersionMS); caml_win32_build = HIWORD(vsfi->dwProductVersionLS); caml_win32_revision = LOWORD(vsfi->dwProductVersionLS); } free(versionInfo); } static UINT startup_codepage = 0; void caml_setup_win32_terminal(void) { if (caml_win32_major >= 10) { startup_codepage = GetConsoleOutputCP(); if (startup_codepage != CP_UTF8) SetConsoleOutputCP(CP_UTF8); } } void caml_restore_win32_terminal(void) { if (startup_codepage != 0) SetConsoleOutputCP(startup_codepage); } /* Detect if a named pipe corresponds to a Cygwin/MSYS pty: see https://github.com/mirror/newlib-cygwin/blob/00e9bf2/winsup/cygwin/dtable.cc#L932 */ typedef BOOL (WINAPI *tGetFileInformationByHandleEx)(HANDLE, FILE_INFO_BY_HANDLE_CLASS, LPVOID, DWORD); static int caml_win32_is_cygwin_pty(HANDLE hFile) { char buffer[1024]; FILE_NAME_INFO * nameinfo = (FILE_NAME_INFO *) buffer; static tGetFileInformationByHandleEx pGetFileInformationByHandleEx = INVALID_HANDLE_VALUE; if (pGetFileInformationByHandleEx == INVALID_HANDLE_VALUE) pGetFileInformationByHandleEx = (tGetFileInformationByHandleEx)GetProcAddress( GetModuleHandle(L"KERNEL32.DLL"), "GetFileInformationByHandleEx"); if (pGetFileInformationByHandleEx == NULL) return 0; /* Get pipe name. GetFileInformationByHandleEx does not NULL-terminate the string, so reduce the buffer size to allow for adding one. */ if (! pGetFileInformationByHandleEx(hFile, FileNameInfo, buffer, sizeof(buffer) - sizeof(WCHAR))) return 0; nameinfo->FileName[nameinfo->FileNameLength / sizeof(WCHAR)] = L'\0'; /* check if this could be a msys pty pipe ('msys-XXXX-ptyN-XX') or a cygwin pty pipe ('cygwin-XXXX-ptyN-XX') */ if ((wcsstr(nameinfo->FileName, L"msys-") || wcsstr(nameinfo->FileName, L"cygwin-")) && wcsstr(nameinfo->FileName, L"-pty")) return 1; return 0; } CAMLexport int caml_win32_isatty(int fd) { DWORD lpMode; HANDLE hFile = (HANDLE)_get_osfhandle(fd); if (hFile == INVALID_HANDLE_VALUE) return 0; switch (GetFileType(hFile)) { case FILE_TYPE_CHAR: /* Both console handles and the NUL device are FILE_TYPE_CHAR. The NUL device returns FALSE for a GetConsoleMode call. _isatty incorrectly only uses GetFileType (see GPR#1321). */ return GetConsoleMode(hFile, &lpMode); case FILE_TYPE_PIPE: /* Cygwin PTYs are implemented using named pipes */ return caml_win32_is_cygwin_pty(hFile); default: break; } return 0; } int caml_num_rows_fd(int fd) { return -1; } /* UCRT clock function returns wall-clock time */ CAMLexport clock_t caml_win32_clock(void) { FILETIME _creation, _exit; CAML_ULONGLONG_FILETIME stime, utime; ULONGLONG clocks_per_sec; if (!(GetProcessTimes(GetCurrentProcess(), &_creation, &_exit, &stime.ft, &utime.ft))) { return (clock_t)(-1); } /* total in 100-nanosecond intervals (1e7 / CLOCKS_PER_SEC) */ clocks_per_sec = 10000000ULL / (ULONGLONG)CLOCKS_PER_SEC; return (clock_t)((stime.ul + utime.ul) / clocks_per_sec); } static double clock_period = 0; void caml_init_os_params(void) { SYSTEM_INFO si; LARGE_INTEGER frequency; /* Get the system page size and allocation granularity. */ GetSystemInfo(&si); CAMLassert(si.dwAllocationGranularity >= si.dwPageSize); caml_plat_pagesize = si.dwPageSize; caml_plat_mmap_alignment = si.dwAllocationGranularity; /* Get the number of nanoseconds for each tick in QueryPerformanceCounter */ QueryPerformanceFrequency(&frequency); clock_period = (1000000000.0 / frequency.QuadPart); } uint64_t caml_time_counter(void) { LARGE_INTEGER now; QueryPerformanceCounter(&now); return (uint64_t)(now.QuadPart * clock_period); } void *caml_plat_mem_map(uintnat size, int reserve_only) { return VirtualAlloc(NULL, size, MEM_RESERVE | (reserve_only ? 0 : MEM_COMMIT), reserve_only ? PAGE_NOACCESS : PAGE_READWRITE); } void* caml_plat_mem_commit(void* mem, uintnat size) { return VirtualAlloc(mem, size, MEM_COMMIT, PAGE_READWRITE); } void caml_plat_mem_decommit(void* mem, uintnat size) { VirtualFree(mem, size, MEM_DECOMMIT); } void caml_plat_mem_unmap(void* mem, uintnat size) { if (!VirtualFree(mem, 0, MEM_RELEASE)) CAMLassert(0); } /* Mapping Win32 error codes to POSIX error codes */ struct error_entry { DWORD win_code; int range; int posix_code; }; static const struct error_entry win_error_table[] = { { ERROR_INVALID_FUNCTION, 0, EINVAL}, { ERROR_FILE_NOT_FOUND, 0, ENOENT}, { ERROR_PATH_NOT_FOUND, 0, ENOENT}, { ERROR_TOO_MANY_OPEN_FILES, 0, EMFILE}, { ERROR_TOO_MANY_LINKS, 0, EMLINK}, { ERROR_ACCESS_DENIED, 0, EACCES}, { ERROR_INVALID_HANDLE, 0, EBADF}, { ERROR_ARENA_TRASHED, 0, ENOMEM}, { ERROR_NOT_ENOUGH_MEMORY, 0, ENOMEM}, { ERROR_INVALID_BLOCK, 0, ENOMEM}, { ERROR_BAD_ENVIRONMENT, 0, E2BIG}, { ERROR_BAD_FORMAT, 0, ENOEXEC}, { ERROR_INVALID_ACCESS, 0, EINVAL}, { ERROR_INVALID_DATA, 0, EINVAL}, { ERROR_INVALID_DRIVE, 0, ENOENT}, { ERROR_CURRENT_DIRECTORY, 0, EACCES}, { ERROR_NOT_SAME_DEVICE, 0, EXDEV}, { ERROR_NO_MORE_FILES, 0, ENOENT}, { ERROR_LOCK_VIOLATION, 0, EACCES}, { ERROR_BAD_NETPATH, 0, ENOENT}, { ERROR_NETWORK_ACCESS_DENIED, 0, EACCES}, { ERROR_BAD_NET_NAME, 0, ENOENT}, { ERROR_FILE_EXISTS, 0, EEXIST}, { ERROR_CANNOT_MAKE, 0, EACCES}, { ERROR_FAIL_I24, 0, EACCES}, { ERROR_INVALID_PARAMETER, 0, EINVAL}, { ERROR_NO_PROC_SLOTS, 0, EAGAIN}, { ERROR_DRIVE_LOCKED, 0, EACCES}, { ERROR_BROKEN_PIPE, 0, EPIPE}, { ERROR_NO_DATA, 0, EPIPE}, { ERROR_DISK_FULL, 0, ENOSPC}, { ERROR_INVALID_TARGET_HANDLE, 0, EBADF}, { ERROR_INVALID_HANDLE, 0, EINVAL}, { ERROR_WAIT_NO_CHILDREN, 0, ECHILD}, { ERROR_CHILD_NOT_COMPLETE, 0, ECHILD}, { ERROR_DIRECT_ACCESS_HANDLE, 0, EBADF}, { ERROR_NEGATIVE_SEEK, 0, EINVAL}, { ERROR_SEEK_ON_DEVICE, 0, EACCES}, { ERROR_DIR_NOT_EMPTY, 0, ENOTEMPTY}, { ERROR_NOT_LOCKED, 0, EACCES}, { ERROR_BAD_PATHNAME, 0, ENOENT}, { ERROR_MAX_THRDS_REACHED, 0, EAGAIN}, { ERROR_LOCK_FAILED, 0, EACCES}, { ERROR_ALREADY_EXISTS, 0, EEXIST}, { ERROR_FILENAME_EXCED_RANGE, 0, ENOENT}, { ERROR_NESTING_NOT_ALLOWED, 0, EAGAIN}, { ERROR_NOT_ENOUGH_QUOTA, 0, ENOMEM}, { ERROR_INVALID_STARTING_CODESEG, ERROR_INFLOOP_IN_RELOC_CHAIN - ERROR_INVALID_STARTING_CODESEG, ENOEXEC }, { ERROR_WRITE_PROTECT, ERROR_SHARING_BUFFER_EXCEEDED - ERROR_WRITE_PROTECT, EACCES }, { ERROR_PRIVILEGE_NOT_HELD, 0, EPERM}, { WSAEINVAL, 0, EINVAL }, { WSAEACCES, 0, EACCES }, { WSAEBADF, 0, EBADF }, { WSAEFAULT, 0, EFAULT }, { WSAEINTR, 0, EINTR }, { WSAEINVAL, 0, EINVAL }, { WSAEMFILE, 0, EMFILE }, { WSAENAMETOOLONG, 0, ENAMETOOLONG }, { WSAENOTEMPTY, 0, ENOTEMPTY }, { 0, -1, 0 } }; int caml_posixerr_of_win32err(unsigned int errcode) { for (int i = 0; win_error_table[i].range >= 0; i++) { if (errcode >= win_error_table[i].win_code && errcode <= win_error_table[i].win_code + win_error_table[i].range) { return win_error_table[i].posix_code; } } return 0; } value caml_win32_xdg_defaults(void) { CAMLparam0(); CAMLlocal2(opath, result); PWSTR wpath; result = Val_emptylist; if (SHGetKnownFolderPath(&FOLDERID_ProgramData, 0, NULL, &wpath) == S_OK) { opath = caml_copy_string_of_utf16(wpath); result = caml_alloc_2(Tag_cons, opath, result); } CoTaskMemFree(wpath); /* wpath must be freed, even on error */ if (SHGetKnownFolderPath(&FOLDERID_RoamingAppData, 0, NULL, &wpath) == S_OK) { opath = caml_copy_string_of_utf16(wpath); result = caml_alloc_2(Tag_cons, opath, result); } CoTaskMemFree(wpath); if (SHGetKnownFolderPath(&FOLDERID_LocalAppData, 0, NULL, &wpath) == S_OK) { opath = caml_copy_string_of_utf16(wpath); result = caml_alloc_2(Tag_cons, opath, result); } CoTaskMemFree(wpath); CAMLreturn(result); }