// Copy file times
CAMLprim value copy_file_times(value in_h_val, value out_h_val) {
CAMLparam2(in_h_val, out_h_val);
int good;
#if defined(WIN32)
HANDLE in_h = Handle_val(in_h_val);
HANDLE out_h = Handle_val(out_h_val);
FILETIME create;
FILETIME access;
FILETIME modify;
good = GetFileTime(in_h, &create, &access, &modify);
if(good) {
good = SetFileTime(out_h, &create, &access, &modify);
}
#else
int in_h = Int_val(in_h_val);
int out_h = Int_val(out_h_val);
struct stat s;
struct timeval set[2];
good = !fstat(in_h, &s);
if(good) {
set[0].tv_sec = s.st_atime;
set[0].tv_usec = 0;
set[1].tv_sec = s.st_mtime;
set[1].tv_usec = 0;
good = !futimes(out_h, set);
}
#endif
CAMLreturn(Val_bool(good));
}
/*#include <stdio.h>*/
CAMLprim value caml_dynlink_lookup_symbol(value handle, value symbolname)
{
void * symb;
value result;
symb = caml_dlsym(Handle_val(handle), String_val(symbolname));
/* printf("%s = 0x%lx\n", String_val(symbolname), symb);
fflush(stdout); */
if (symb == NULL) return Val_unit /*caml_failwith(caml_dlerror())*/;
result = caml_alloc_small(1, Abstract_tag);
Handle_val(result) = symb;
return result;
}
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));
}
int win_set_inherit(value fd, BOOL inherit)
{
HANDLE oldh, newh;
oldh = Handle_val(fd);
if (! DuplicateHandle(GetCurrentProcess(), oldh,
GetCurrentProcess(), &newh,
0L, inherit, DUPLICATE_SAME_ACCESS)) {
win32_maperr(GetLastError());
return -1;
}
Handle_val(fd) = newh;
CloseHandle(oldh);
return 0;
}
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);
}
static HANDLE handle_of_descr(value x)
{
if(Descr_kind_val(x) != KIND_HANDLE){
failwith("mlterminal(the channel is not a file handle)");
}
return Handle_val(x);
}
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);
}
value onlyWin32_create_process_chdir_native(value cmd, value cmdline, value env,
value fd1, value fd2, value fd3, value maybe_chdir)
{
PROCESS_INFORMATION pi;
STARTUPINFO si;
char * exefile, * envp;
int flags;
LPCTSTR lpCurrentDirectory = NULL;
exefile = search_exe_in_path(String_val(cmd));
if (env != Val_int(0)) {
envp = String_val(Field(env, 0));
} else {
envp = NULL;
}
/* Prepare stdin/stdout/stderr redirection */
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);
/* If we do not have a console window, then we must create one
before running the process (keep it hidden for apparence).
If we are starting a GUI application, the newly created
console should not matter. */
if (onlyWin32_has_console())
flags = 0;
else {
flags = CREATE_NEW_CONSOLE;
si.dwFlags = (STARTF_USESHOWWINDOW | STARTF_USESTDHANDLES);
si.wShowWindow = SW_HIDE;
}
if( maybe_chdir != Val_int(0) ){
lpCurrentDirectory = String_val(Field(maybe_chdir,0));
}
/* Create the process */
if (! CreateProcess(NULL, String_val(cmdline), NULL, NULL,
TRUE, flags, envp, lpCurrentDirectory, &si, &pi)) {
win32_maperr(GetLastError());
uerror("create_process", cmd);
}
CloseHandle(pi.hThread);
/* Return the process handle as pseudo-PID
(this is consistent with the wait() emulation in the MSVC C library */
return Val_long(pi.hProcess);
}
value win_alloc_handle(HANDLE h)
{
value res = alloc_custom(&win_handle_ops, sizeof(struct filedescr), 0, 1);
Handle_val(res) = h;
Descr_kind_val(res) = KIND_HANDLE;
CRT_fd_val(res) = NO_CRT_FD;
return res;
}
CAMLprim value win_findclose(value valh)
{
if (! FindClose(Handle_val(valh))) {
win32_maperr(GetLastError());
uerror("closedir", Nothing);
}
return Val_unit;
}
CAMLprim value unix_lseek_64(value fd, value ofs, value cmd)
{
__int64 ret;
ret = caml_set_file_pointer(Handle_val(fd), Int64_val(ofs),
seek_command_table[Int_val(cmd)]);
return copy_int64(ret);
}
static value do_fstat(value handle, int use_64)
{
int ret;
struct _stat64 buf;
__int64 st_ino;
HANDLE h;
DWORD ft;
st_ino = 0;
memset(&buf, 0, sizeof buf);
buf.st_nlink = 1;
h = Handle_val(handle);
ft = GetFileType(h) & ~FILE_TYPE_REMOTE;
switch(ft) {
case FILE_TYPE_DISK:
if (!safe_do_stat(0, use_64, NULL, Handle_val(handle), &st_ino, &buf)) {
uerror("fstat", Nothing);
}
break;
case FILE_TYPE_CHAR:
buf.st_mode = S_IFCHR;
break;
case FILE_TYPE_PIPE:
{
DWORD n_avail;
if (Descr_kind_val(handle) == KIND_SOCKET) {
buf.st_mode = S_IFSOCK;
}
else {
buf.st_mode = S_IFIFO;
}
if (PeekNamedPipe(h, NULL, 0, NULL, &n_avail, NULL)) {
buf.st_size = n_avail;
}
}
break;
case FILE_TYPE_UNKNOWN:
unix_error(EBADF, "fstat", Nothing);
default:
win32_maperr(GetLastError());
uerror("fstat", Nothing);
}
return stat_aux(use_64, st_ino, &buf);
}
CAMLprim value win_findclosew(value valh)
{
CAMLparam1(valh);
if (! FindClose(Handle_val(valh))) {
win32_maperr(GetLastError());
uerror("closedir", Nothing);
}
CAMLreturn (Val_unit);
}
int win_CRT_fd_of_filedescr(value handle)
{
if (CRT_fd_val(handle) != NO_CRT_FD) {
return CRT_fd_val(handle);
} else {
int fd = _open_osfhandle((long) Handle_val(handle), O_BINARY);
if (fd == -1) uerror("channel_of_descr", Nothing);
return fd;
}
}
CAMLprim value unix_fstat_64(value handle)
{
int ret;
struct _stat64 buf;
__int64 st_ino;
if (!do_stat(0, 1, NULL, 0, Handle_val(handle), &st_ino, &buf)) {
uerror("fstat", Nothing);
}
return stat_aux(1, st_ino, &buf);
}
/* Guess handle type */
static SELECTHANDLETYPE get_handle_type(value fd)
{
DWORD mode;
SELECTHANDLETYPE res;
CAMLparam1(fd);
mode = 0;
res = SELECT_HANDLE_NONE;
if (Descr_kind_val(fd) == KIND_SOCKET)
{
res = SELECT_HANDLE_SOCKET;
}
else
{
switch(GetFileType(Handle_val(fd)))
{
case FILE_TYPE_DISK:
res = SELECT_HANDLE_DISK;
break;
case FILE_TYPE_CHAR: /* character file or a console */
if (GetConsoleMode(Handle_val(fd), &mode) != 0)
{
res = SELECT_HANDLE_CONSOLE;
}
else
{
res = SELECT_HANDLE_NONE;
};
break;
case FILE_TYPE_PIPE: /* a named or an anonymous pipe (socket already handled) */
res = SELECT_HANDLE_PIPE;
break;
};
};
CAMLreturnT(SELECTHANDLETYPE, res);
}
static Tcl_Channel tcl_channel(value fd, int flags)
{
HANDLE h = Handle_val(fd);
int optval, optsize;
optsize = sizeof(optval);
if (getsockopt((SOCKET) h, SOL_SOCKET, SO_TYPE,
(char *)&optval, &optsize) == 0)
return Tcl_MakeTcpClientChannel((ClientData) h);
else
return Tcl_MakeFileChannel((ClientData) h, flags);
}
CAMLprim value unix_lseek(value fd, value ofs, value cmd)
{
__int64 ret;
ret = caml_set_file_pointer(Handle_val(fd), Long_val(ofs),
seek_command_table[Int_val(cmd)]);
if (ret > Max_long) {
win32_maperr(ERROR_ARITHMETIC_OVERFLOW);
uerror("lseek", Nothing);
}
return Val_long(ret);
}
int win_set_inherit(value fd, BOOL inherit)
{
/* According to the MSDN, SetHandleInformation may not work
for console handles on WinNT4 and earlier versions. */
if (! SetHandleInformation(Handle_val(fd),
HANDLE_FLAG_INHERIT,
inherit ? HANDLE_FLAG_INHERIT : 0)) {
win32_maperr(GetLastError());
return -1;
}
return 0;
}
CAMLprim value caml_dynlink_open_lib(value mode, value filename)
{
void * handle;
value result;
caml_gc_message(0x100, "Opening shared library %s\n",
(uintnat) String_val(filename));
handle = caml_dlopen(String_val(filename), Int_val(mode), 1);
if (handle == NULL) caml_failwith(caml_dlerror());
result = caml_alloc_small(1, Abstract_tag);
Handle_val(result) = handle;
return result;
}
CAMLprim value netsys_int64_of_file_descr(value fd) {
#ifdef _WIN32
switch (Descr_kind_val(fd)) {
case KIND_HANDLE:
return copy_int64((intnat) (Handle_val(fd)));
case KIND_SOCKET:
return copy_int64((intnat) (Socket_val(fd)));
}
return copy_int64(0);
#else
return copy_int64(Long_val(fd));
#endif
}
CAMLprim value unix_dup2(value fd1, value fd2)
{
HANDLE oldh, newh;
oldh = Handle_val(fd2);
if (! DuplicateHandle(GetCurrentProcess(), Handle_val(fd1),
GetCurrentProcess(), &newh,
0L, TRUE, DUPLICATE_SAME_ACCESS)) {
win32_maperr(GetLastError());
return -1;
}
Handle_val(fd2) = newh;
if (Descr_kind_val(fd2) == KIND_SOCKET)
closesocket((SOCKET) oldh);
else
CloseHandle(oldh);
Descr_kind_val(fd2) = Descr_kind_val(fd1);
/* Reflect the dup2 on the CRT fds, if any */
if (CRT_fd_val(fd1) != NO_CRT_FD || CRT_fd_val(fd2) != NO_CRT_FD)
_dup2(win_CRT_fd_of_filedescr(fd1), win_CRT_fd_of_filedescr(fd2));
return Val_unit;
}
CAMLprim value caml_dynlink_get_current_libs(value unit)
{
CAMLparam0();
CAMLlocal1(res);
int i;
res = caml_alloc_tuple(shared_libs.size);
for (i = 0; i < shared_libs.size; i++) {
value v = caml_alloc_small(1, Abstract_tag);
Handle_val(v) = shared_libs.contents[i];
Store_field(res, i, v);
}
CAMLreturn(res);
}
CAMLprim value
uwt_udp_send_queue_count_na(value o_udp)
{
value ret;
struct handle * h = Handle_val(o_udp);
if ( HANDLE_IS_INVALID_UNINIT(h) ){
ret = Val_long(0);
}
else {
uv_udp_t* u = (uv_udp_t*)h->handle;
ret = Val_long((intnat)u->send_queue_count);
}
return ret;
}
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 unix_dup(value fd)
{
HANDLE newh;
value newfd;
int kind = Descr_kind_val(fd);
if (! DuplicateHandle(GetCurrentProcess(), Handle_val(fd),
GetCurrentProcess(), &newh,
0L, TRUE, DUPLICATE_SAME_ACCESS)) {
win32_maperr(GetLastError());
return -1;
}
newfd = win_alloc_handle(newh);
Descr_kind_val(newfd) = kind;
return newfd;
}
CAMLprim value lwt_text_term_size(value fd)
{
HANDLE handle;
CONSOLE_SCREEN_BUFFER_INFO info;
if (!GetConsoleScreenBufferInfo(Handle_val(fd), &info)) {
win32_maperr(GetLastError());
uerror("GetConsoleScreenBufferInfo", Nothing);
}
value result = caml_alloc_tuple(2);
Field(result, 0) = Val_int(info.dwSize.X);
Field(result, 1) = Val_int(info.dwSize.Y);
return result;
}
// Make a function to see if a thread is still alive
// *nix uses pthread_kill(pthread_t thread, 0), Windows uses GetExitCodeThread(HANDLE hThread, &exit_code)
CAMLprim value thread_is_alive(value thread_id_val) {
CAMLparam1(thread_id_val);
int still_alive;
#if defined(WIN32)
HANDLE thread_id = Handle_val(thread_id_val);
DWORD exit_code;
if(GetExitCodeThread(thread_id, &exit_code)) {
still_alive = (exit_code == STILL_ACTIVE);
} else {
caml_failwith("Can't get status of thread");
}
#else
int thread_id = Int_val(thread_id_val);
#endif
CAMLreturn(Val_bool(still_alive));
}
CAMLprim value win_findnext(value valh)
{
WIN32_FIND_DATA fileinfo;
BOOL retcode;
retcode = FindNextFile(Handle_val(valh), &fileinfo);
if (!retcode) {
DWORD err = GetLastError();
if (err == ERROR_NO_MORE_FILES)
raise_end_of_file();
else {
win32_maperr(err);
uerror("readdir", Nothing);
}
}
return copy_string(fileinfo.cFileName);
}
CAMLprim value caml_dynlink_open_lib(value mode, value filename)
{
void * handle;
value result;
char * p;
caml_gc_log("Opening shared library %s", String_val(filename));
p = caml_strdup(String_val(filename));
caml_enter_blocking_section();
handle = caml_dlopen(p, Int_val(mode), 1);
caml_leave_blocking_section();
caml_stat_free(p);
if (handle == NULL) caml_failwith(caml_dlerror());
result = caml_alloc_small(1, Abstract_tag);
Handle_val(result) = handle;
return result;
}
