CAMLprim value unix_getaddrinfo(value vnode, value vserv, value vopts) { CAMLparam3(vnode, vserv, vopts); CAMLlocal3(vres, v, e); mlsize_t len; char * node, * serv; struct addrinfo hints; struct addrinfo * res, * r; int retcode; /* Extract "node" parameter */ len = string_length(vnode); if (len == 0) { node = NULL; } else { node = stat_alloc(len + 1); strcpy(node, String_val(vnode)); } /* Extract "service" parameter */ len = string_length(vserv); if (len == 0) { serv = NULL; } else { serv = stat_alloc(len + 1); strcpy(serv, String_val(vserv)); } /* Parse options, set hints */ memset(&hints, 0, sizeof(hints)); hints.ai_family = PF_UNSPEC; for (/*nothing*/; Is_block(vopts); vopts = Field(vopts, 1)) { v = Field(vopts, 0); if (Is_block(v)) switch (Tag_val(v)) { case 0: /* AI_FAMILY of socket_domain */ hints.ai_family = socket_domain_table[Int_val(Field(v, 0))]; break; case 1: /* AI_SOCKTYPE of socket_type */ hints.ai_socktype = socket_type_table[Int_val(Field(v, 0))]; break; case 2: /* AI_PROTOCOL of int */ hints.ai_protocol = Int_val(Field(v, 0)); break; } else switch (Int_val(v)) { case 0: /* AI_NUMERICHOST */ hints.ai_flags |= AI_NUMERICHOST; break; case 1: /* AI_CANONNAME */ hints.ai_flags |= AI_CANONNAME; break; case 2: /* AI_PASSIVE */ hints.ai_flags |= AI_PASSIVE; break; } } /* Do the call */ enter_blocking_section(); retcode = getaddrinfo(node, serv, &hints, &res); leave_blocking_section(); if (node != NULL) stat_free(node); if (serv != NULL) stat_free(serv); /* Convert result */ vres = Val_int(0); if (retcode == 0) { for (r = res; r != NULL; r = r->ai_next) { e = convert_addrinfo(r); v = alloc_small(2, 0); Field(v, 0) = e; Field(v, 1) = vres; vres = v; } freeaddrinfo(res); } CAMLreturn(vres); }
CAMLprim value sunml_lsolver_call_atimes(value vcptr, value vv, value vz) { CAMLparam3(vcptr, vv, vz); caml_raise_constant(SUNDIALS_EXN(NotImplementedBySundialsVersion)); CAMLreturn(Val_unit); }
CAMLprim value unix_lockf(value fd, value cmd, value span) { CAMLparam3(fd, cmd, span); OVERLAPPED overlap; intnat l_len; HANDLE h; OSVERSIONINFO version; LARGE_INTEGER cur_position; LARGE_INTEGER beg_position; LARGE_INTEGER lock_len; LARGE_INTEGER zero; DWORD err = NO_ERROR; version.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); if(GetVersionEx(&version) == 0) { invalid_argument("lockf only supported on WIN32_NT platforms: could not determine current platform."); } if(version.dwPlatformId != VER_PLATFORM_WIN32_NT) { invalid_argument("lockf only supported on WIN32_NT platforms"); } h = Handle_val(fd); l_len = Long_val(span); /* No matter what, we need the current position in the file */ zero.HighPart = zero.LowPart = 0; set_file_pointer(h, zero, &cur_position, FILE_CURRENT); /* All unused fields must be set to zero */ memset(&overlap, 0, sizeof(overlap)); if(l_len == 0) { /* Lock from cur to infinity */ lock_len.QuadPart = -1; overlap.OffsetHigh = cur_position.HighPart; overlap.Offset = cur_position.LowPart ; } else if(l_len > 0) { /* Positive file offset */ lock_len.QuadPart = l_len; overlap.OffsetHigh = cur_position.HighPart; overlap.Offset = cur_position.LowPart ; } else { /* Negative file offset */ lock_len.QuadPart = - l_len; if (lock_len.QuadPart > cur_position.QuadPart) { errno = EINVAL; uerror("lockf", Nothing); } beg_position.QuadPart = cur_position.QuadPart - lock_len.QuadPart; overlap.OffsetHigh = beg_position.HighPart; overlap.Offset = beg_position.LowPart ; } switch(Int_val(cmd)) { case 0: /* F_ULOCK - unlock */ if (! UnlockFileEx(h, 0, lock_len.LowPart, lock_len.HighPart, &overlap)) err = GetLastError(); break; case 1: /* F_LOCK - blocking write lock */ enter_blocking_section(); if (! LockFileEx(h, LOCKFILE_EXCLUSIVE_LOCK, 0, lock_len.LowPart, lock_len.HighPart, &overlap)) err = GetLastError(); leave_blocking_section(); break; case 2: /* F_TLOCK - non-blocking write lock */ if (! LockFileEx(h, LOCKFILE_FAIL_IMMEDIATELY | LOCKFILE_EXCLUSIVE_LOCK, 0, lock_len.LowPart, lock_len.HighPart, &overlap)) err = GetLastError(); break; case 3: /* F_TEST - check whether a write lock can be obtained */ /* I'm doing this by aquiring an immediate write * lock and then releasing it. It is not clear that * this behavior matches anything in particular, but * it is not clear the nature of the lock test performed * by ocaml (unix) currently. */ if (LockFileEx(h, LOCKFILE_FAIL_IMMEDIATELY | LOCKFILE_EXCLUSIVE_LOCK, 0, lock_len.LowPart, lock_len.HighPart, &overlap)) { UnlockFileEx(h, 0, lock_len.LowPart, lock_len.HighPart, &overlap); } else { err = GetLastError(); } break; case 4: /* F_RLOCK - blocking read lock */ enter_blocking_section(); if (! LockFileEx(h, 0, 0, lock_len.LowPart, lock_len.HighPart, &overlap)) err = GetLastError(); leave_blocking_section(); break; case 5: /* F_TRLOCK - non-blocking read lock */ if (! LockFileEx(h, LOCKFILE_FAIL_IMMEDIATELY, 0, lock_len.LowPart, lock_len.HighPart, &overlap)) err = GetLastError(); break; default: errno = EINVAL; uerror("lockf", Nothing); } if (err != NO_ERROR) { win32_maperr(err); uerror("lockf", Nothing); } CAMLreturn(Val_unit); }
value ml_crc32_init (value unit) { CAMLparam1 (unit); InitCrcTable(); CAMLreturn (unit); }
CAMLprim value int32_of_int64(value v) { CAMLparam1(v); CAMLreturn (copy_int32((int32_t)Int64_val(v))); }
CAMLprim value netcgi2_apache_request_finfo (value rv) { CAMLparam1 (rv); request_rec *r = Request_rec_val (rv); CAMLlocal5 (v, sb, atime, mtime, ctime); #if APACHE2 if (r->finfo.filetype != APR_NOFILE) /* Some statbuf */ { atime = (r->finfo.valid & APR_FINFO_ATIME) ? copy_double ((double) apr_time_sec (r->finfo.atime)) : copy_double (0.); mtime = (r->finfo.valid & APR_FINFO_MTIME) ? copy_double ((double) apr_time_sec (r->finfo.mtime)) : copy_double (0.); ctime = (r->finfo.valid & APR_FINFO_CTIME) ? copy_double ((double) apr_time_sec (r->finfo.ctime)) : copy_double (0.); sb = alloc_small (12, 0); Field (sb, 0) = Val_int (r->finfo.device); Field (sb, 1) = Val_int (r->finfo.inode); Field (sb, 2) = cst_to_constr (r->finfo.filetype, file_kind_table, sizeof (file_kind_table) / sizeof (int), 0); Field (sb, 3) = Val_int (r->finfo.protection); Field (sb, 4) = Val_int (r->finfo.nlink); Field (sb, 5) = Val_int (r->finfo.user); Field (sb, 6) = Val_int (r->finfo.group); Field (sb, 7) = Val_int (0); /* FIXME rdev? */ Field (sb, 8) = Val_int (r->finfo.size); /* FIXME 64 bit file offsets */ Field (sb, 9) = atime; Field (sb, 10) = mtime; Field (sb, 11) = ctime; v = alloc (1, 0); /* The "Some" block. */ Field (v, 0) = sb; } else v = Val_int (0); /* None. */ #else /* not APACHE2 */ if (r->finfo.st_mode) /* Some statbuf */ { /* This code copied and modified from otherlibs/unix/stat.c. */ atime = copy_double ((double) r->finfo.st_atime); mtime = copy_double ((double) r->finfo.st_mtime); ctime = copy_double ((double) r->finfo.st_ctime); sb = alloc_small (12, 0); Field (sb, 0) = Val_int (r->finfo.st_dev); Field (sb, 1) = Val_int (r->finfo.st_ino); Field (sb, 2) = cst_to_constr (r->finfo.st_mode & S_IFMT, file_kind_table, sizeof (file_kind_table) / sizeof (int), 0); Field (sb, 3) = Val_int (r->finfo.st_mode & 07777); Field (sb, 4) = Val_int (r->finfo.st_nlink); Field (sb, 5) = Val_int (r->finfo.st_uid); Field (sb, 6) = Val_int (r->finfo.st_gid); Field (sb, 7) = Val_int (r->finfo.st_rdev); Field (sb, 8) = Val_int (r->finfo.st_size); /* FIXME: 64 bit file offsets */ Field (sb, 9) = atime; Field (sb, 10) = mtime; Field (sb, 11) = ctime; v = alloc (1, 0); /* The "Some" block. */ Field (v, 0) = sb; } else v = Val_int (0); /* None. */ #endif /* not APACHE2 */ CAMLreturn (v); }
CAMLprim value brlapiml_enterRawMode(value handle, value driverName) { CAMLparam2(handle, driverName); brlapiCheckError(enterRawMode, String_val(driverName)); CAMLreturn(Val_unit); }
CAMLprim value int32_of_nativeint(value v) { CAMLparam1(v); CAMLreturn (copy_int32((int32_t)Nativeint_val(v))); }
CAMLprim value brlapiml_writeText(value handle, value cursor, value text) { CAMLparam3(handle, cursor, text); brlapiCheckError(writeText, Int_val(cursor), String_val(text)); CAMLreturn(Val_unit); }
CAMLprim value brlapiml_acceptAllKeys(value handle, value unit) { CAMLparam2(handle, unit); brlapiCheckError(acceptAllKeys); CAMLreturn(Val_unit); }
CAMLprim value brlapiml_setFocus(value handle, value tty) { CAMLparam2(handle, tty); brlapiCheckError(setFocus, Int_val(tty)); CAMLreturn(Val_unit); }
CAMLprim value brlapiml_closeConnection(value handle, value unit) { CAMLparam2(handle, unit); brlapi(closeConnection); CAMLreturn(Val_unit); }
/* For debugging */ value hh_heap_size() { CAMLparam0(); CAMLreturn(Val_long(*heap - heap_init)); }
CAMLexport value caml_check_urgent_gc (value extra_root) { CAMLparam1 (extra_root); if (caml_force_major_slice) caml_minor_collection(); CAMLreturn (extra_root); }
CAMLprim value brlapiml_leaveRawMode(value handle, value unit) { CAMLparam2(handle, unit); brlapi(leaveRawMode); CAMLreturn(Val_unit); }
CAMLprim value int32_of_uint56(value v) { CAMLparam1(v); CAMLreturn (copy_int32((int32_t)Uint56_val(v))); }
CAMLprim value brlapiml_suspendDriver(value handle, value driverName) { CAMLparam2(handle, driverName); brlapiCheckError(suspendDriver, String_val(driverName)); CAMLreturn(Val_unit); }
CAMLprim value int32_of_float(value v) { CAMLparam1(v); CAMLreturn (copy_int32((int32_t)Double_val(v))); }
CAMLprim value brlapiml_resumeDriver(value handle, value unit) { CAMLparam2(handle, unit); brlapi(resumeDriver); CAMLreturn(Val_unit); }
CAMLprim value re_replacement_text(value repl, value groups, value orig) { CAMLparam3(repl, groups, orig); CAMLlocal1(res); mlsize_t start, end, len, n; char * p, * q; int c; len = 0; p = String_val(repl); n = string_length(repl); while (n > 0) { c = *p++; n--; if(c != '\\') len++; else { if (n == 0) failwith("Str.replace: illegal backslash sequence"); c = *p++; n--; switch (c) { case '\\': len++; break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': c -= '0'; if (c*2 >= Wosize_val(groups)) failwith("Str.replace: reference to unmatched group"); start = Long_val(Field(groups, c*2)); end = Long_val(Field(groups, c*2 + 1)); if (start == (mlsize_t) -1) failwith("Str.replace: reference to unmatched group"); len += end - start; break; default: len += 2; break; } } } res = alloc_string(len); p = String_val(repl); q = String_val(res); n = string_length(repl); while (n > 0) { c = *p++; n--; if(c != '\\') *q++ = c; else { c = *p++; n--; switch (c) { case '\\': *q++ = '\\'; break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': c -= '0'; start = Long_val(Field(groups, c*2)); end = Long_val(Field(groups, c*2 + 1)); len = end - start; memmove (q, &Byte(orig, start), len); q += len; break; default: *q++ = '\\'; *q++ = c; break; } } } CAMLreturn(res); }
/* exception occurs */ CAMLprim value brlapiml_setExceptionHandler(value unit) { CAMLparam1(unit); brlapi_setExceptionHandler(raise_brlapi_exception); CAMLreturn(Val_unit); }
value get_memory_usage() { CAMLparam0(); CAMLreturn(Val_long(usage())); }
static int compareHandle(value h1, value h2) { CAMLparam2(h1, h2); CAMLreturn(memcmp(Data_custom_val(h1), Data_custom_val(h2), brlapi_getHandleSize())); }
value ml_qapp_exec (value self) { CAMLparam1(self); CAMLreturn( Val_int (((QApplication*)self)->exec()) ); }
CAMLprim value sunml_lsolver_call_psetup(value vcptr) { CAMLparam1(vcptr); caml_raise_constant(SUNDIALS_EXN(NotImplementedBySundialsVersion)); CAMLreturn(Val_unit); }
CAMLprim value uint64_of_int8(value v) { CAMLparam1(v); CAMLreturn (copy_uint64((uint64_t)Int8_val(v))); }
static ssize_t recv_buffer(int fd, int fds[3]) { struct iovec iov = { .iov_base = buffer, .iov_len = sizeof(buffer) }; struct msghdr msg = { .msg_iov = &iov, .msg_iovlen = 1, .msg_controllen = CMSG_SPACE(3 * sizeof(int)), }; msg.msg_control = alloca(msg.msg_controllen); memset(msg.msg_control, 0, msg.msg_controllen); ssize_t recvd; NO_EINTR(recvd, recvmsg(fd, &msg, 0)); if (recvd == -1) { perror("recvmsg"); return -1; } if (recvd < 4) { ssize_t recvd_; do { NO_EINTR(recvd_, recv(fd, buffer + recvd, sizeof(buffer) - recvd, 0)); if (recvd_ > 0) recvd += recvd_; } while (recvd_ > 0 && recvd < 4); } size_t target = -1; if (recvd > 4) { target = unbyte(buffer[0],0) | unbyte(buffer[1],1) | unbyte(buffer[2],2) | unbyte(buffer[3],3); if (recvd < target) { ssize_t recvd_; do { NO_EINTR(recvd_, recv(fd, buffer + recvd, sizeof(buffer) - recvd, 0)); if (recvd_ > 0) recvd += recvd_; } while (recvd_ > 0 && recvd < target); } } struct cmsghdr *cm = CMSG_FIRSTHDR(&msg); int *fds0 = (int*)CMSG_DATA(cm); int nfds = (cm->cmsg_len - CMSG_LEN(0)) / sizeof(int); /* Check malformed packet */ if (nfds != 3 || recvd != target || buffer[recvd-1] != '\0') { int i; for (i = 0; i < nfds; ++i) close(fds0[i]); return -1; } fds[0] = fds0[0]; fds[1] = fds0[1]; fds[2] = fds0[2]; return recvd; } value ml_merlin_server_setup(value path, value strfd) { CAMLparam2(path, strfd); CAMLlocal2(payload, ret); char *endptr = NULL; int fd = strtol(String_val(strfd), &endptr, 0); if (endptr && *endptr == '\0') { /* (path, fd) */ payload = caml_alloc(2, 0); Store_field(payload, 0, path); Store_field(payload, 1, Val_int(fd)); /* Some payload */ ret = caml_alloc(1, 0); Store_field(ret, 0, payload); } else { fprintf(stderr, "ml_merlin_server_setup(\"%s\",\"%s\"): invalid argument\n", String_val(path), String_val(strfd)); unlink(String_val(path)); /* None */ ret = Val_unit; } CAMLreturn(ret); } value ml_merlin_server_accept(value server, value val_timeout) { CAMLparam2(server, val_timeout); CAMLlocal4(ret, client, args, context); // Compute timeout double timeout = Double_val(val_timeout); struct timeval tv; tv.tv_sec = timeout; tv.tv_usec = (timeout - tv.tv_sec) * 1000000; // Select on server int serverfd = Int_val(Field(server, 1)); int selectres; fd_set readset; do { FD_ZERO(&readset); FD_SET(serverfd, &readset); selectres = select(serverfd + 1, &readset, NULL, NULL, &tv); } while (selectres == -1 && errno == EINTR); int fds[3], clientfd; ssize_t len = -1; if (selectres > 0) { NO_EINTR(clientfd, accept(serverfd, NULL, NULL)); len = recv_buffer(clientfd, fds); } if (len == -1) ret = Val_unit; /* None */ else { context = caml_alloc(4, 0); /* (clientfd, stdin, stdout, stderr) */ Store_field(context, 0, Val_int(clientfd)); Store_field(context, 1, Val_int(fds[0])); Store_field(context, 2, Val_int(fds[1])); Store_field(context, 3, Val_int(fds[2])); ssize_t i, j; int argc = 0; for (i = 4; i < len; ++i) if (buffer[i] == '\0') argc += 1; args = caml_alloc(argc, 0); argc = 0; for (i = 4, j = 4; i < len; ++i) { if (buffer[i] == '\0') { Store_field(args, argc, caml_copy_string((const char *)&buffer[j])); j = i + 1; argc += 1; } } client = caml_alloc(2, 0); /* (context, args) */ Store_field(client, 0, context); Store_field(client, 1, args); ret = caml_alloc(1, 0); /* Some client */ Store_field(ret, 0, client); } CAMLreturn(ret); }
CAMLprim value uint64_of_nativeint(value v) { CAMLparam1(v); CAMLreturn (copy_uint64((uint64_t)Nativeint_val(v))); }
CAMLprim value uint64_of_float(value v) { CAMLparam1(v); CAMLreturn (copy_uint64((uint64_t)Double_val(v))); }
CAMLprim value uint64_of_uint56(value v) { CAMLparam1(v); CAMLreturn (copy_uint64((uint64_t)Uint56_val(v))); }