CAMLexport void caml_seek_in(struct channel *channel, file_offset dest)
{
if (dest >= channel->offset - (channel->max - channel->buff) &&
dest <= channel->offset) {
channel->curr = channel->max - (channel->offset - dest);
} else {
caml_sys_error(NO_ARG);
caml_leave_blocking_section();
channel->offset = dest;
channel->curr = channel->max = channel->buff;
}
}
CAMLprim value ocaml_ssl_set_client_SNI_hostname(value socket, value vhostname)
{
CAMLparam2(socket, vhostname);
SSL *ssl = SSL_val(socket);
char *hostname = String_val(vhostname);
caml_enter_blocking_section();
SSL_set_tlsext_host_name(ssl, hostname);
caml_leave_blocking_section();
CAMLreturn(Val_unit);
}
CAMLprim value ocaml_ssl_get_issuer(value certificate)
{
CAMLparam1(certificate);
X509 *cert = Cert_val(certificate);
caml_enter_blocking_section();
char *issuer = X509_NAME_oneline(X509_get_issuer_name(cert), 0, 0);
caml_leave_blocking_section();
if (!issuer) caml_raise_not_found ();
CAMLreturn(caml_copy_string(issuer));
}
CAMLprim value ocaml_ssl_get_file_descr(value socket)
{
CAMLparam1(socket);
SSL *ssl = SSL_val(socket);
int fd;
caml_enter_blocking_section();
fd = SSL_get_fd(ssl);
caml_leave_blocking_section();
CAMLreturn(Val_int(fd));
}
CAMLprim value ocaml_ssl_get_subject(value certificate)
{
CAMLparam1(certificate);
X509 *cert = Cert_val(certificate);
caml_enter_blocking_section();
char *subject = X509_NAME_oneline(X509_get_subject_name(cert), 0, 0);
caml_leave_blocking_section();
if (subject == NULL) caml_raise_not_found ();
CAMLreturn(caml_copy_string(subject));
}
CAMLprim value ocaml_ssl_get_verify_result(value socket)
{
CAMLparam1(socket);
int ans;
SSL *ssl = SSL_val(socket);
caml_enter_blocking_section();
ans = SSL_get_verify_result(ssl);
caml_leave_blocking_section();
CAMLreturn(Val_int(ans));
}
/* caml_do_read is exported for Cash */
CAMLexport int caml_do_read(int fd, char *p, unsigned int n)
{
int retcode;
do {
caml_enter_blocking_section();
retcode = read(fd, p, n);
caml_leave_blocking_section();
} while (retcode == -1 && errno == EINTR);
if (retcode == -1) caml_sys_io_error(NO_ARG);
return retcode;
}
CAMLprim value ocaml_faad_mp4_total_tracks(value m)
{
CAMLparam1(m);
mp4_t *mp = Mp4_val(m);
int n;
caml_enter_blocking_section();
n = mp4ff_total_tracks(mp->ff);
caml_leave_blocking_section();
CAMLreturn(Val_int(n));
}
CAMLprim value unix_fstat(value fd)
{
int ret;
struct stat buf;
caml_enter_blocking_section();
ret = fstat(Int_val(fd), &buf);
caml_leave_blocking_section();
if (ret == -1) uerror("fstat", Nothing);
if (buf.st_size > Max_long && (buf.st_mode & S_IFMT) == S_IFREG)
unix_error(EOVERFLOW, "fstat", Nothing);
return stat_aux(0, &buf);
}
CAMLprim value bigstring_write_stub(
value v_fd, value v_pos, value v_len, value v_bstr)
{
CAMLparam1(v_bstr);
char *bstr = get_bstr(v_bstr, v_pos);
size_t len = Long_val(v_len);
ssize_t written;
caml_enter_blocking_section();
written = write(Int_val(v_fd), bstr, len);
caml_leave_blocking_section();
if (written == -1) uerror("write", Nothing);
CAMLreturn(Val_long(written));
}
CAMLprim value lo_write_ba_stub(value v_conn, value v_fd,
value v_buf, value v_pos, value v_len)
{
CAMLparam2(v_conn, v_buf);
PGconn *conn = get_conn(v_conn);
value v_res;
size_t len = Long_val(v_len);
char *buf = ((char *) Caml_ba_data_val(v_buf)) + Long_val(v_pos);
caml_enter_blocking_section();
v_res = Val_long(lo_write(conn, Int_val(v_fd), buf, len));
caml_leave_blocking_section();
CAMLreturn(v_res);
}
apr_array_header_t *svn_support_diff(char *rep_path,
char *filename,
int revision1,
int revision2)
{
apr_pool_t *subpool = svn_pool_create(pool);
svn_stringbuf_t * rep = svn_stringbuf_create(rep_path, subpool);
svn_stringbuf_t * file = svn_stringbuf_create(filename, subpool);
caml_enter_blocking_section ();
apr_array_header_t *res = svn_support_diff_call(rep->data,file->data,revision1,revision2,subpool);
caml_leave_blocking_section ();
return res;
}
CAMLprim value ocaml_ssl_ctx_load_verify_locations(value context, value ca_file, value ca_path)
{
CAMLparam3(context, ca_file, ca_path);
SSL_CTX *ctx = Ctx_val(context);
char *CAfile = String_val(ca_file);
char *CApath = String_val(ca_path);
if(*CAfile == 0)
CAfile = NULL;
if(*CApath == 0)
CApath = NULL;
caml_enter_blocking_section();
if(SSL_CTX_load_verify_locations(ctx, CAfile, CApath) != 1)
{
caml_leave_blocking_section();
caml_invalid_argument("cafile or capath");
}
caml_leave_blocking_section();
CAMLreturn(Val_unit);
}
CAMLprim value ocaml_ssl_write_certificate(value vfilename, value certificate)
{
CAMLparam2(vfilename, certificate);
char *filename = String_val(vfilename);
X509 *cert = Cert_val(certificate);
FILE *fh = NULL;
if((fh = fopen(filename, "w")) == NULL)
caml_raise_constant(*caml_named_value("ssl_exn_certificate_error"));
caml_enter_blocking_section();
if(PEM_write_X509(fh, cert) == 0)
{
fclose(fh);
caml_leave_blocking_section();
caml_raise_constant(*caml_named_value("ssl_exn_certificate_error"));
}
fclose(fh);
caml_leave_blocking_section();
CAMLreturn(Val_unit);
}
CAMLprim value ocaml_ssl_get_current_cipher(value socket)
{
CAMLparam1(socket);
SSL *ssl = SSL_val(socket);
caml_enter_blocking_section();
SSL_CIPHER *cipher = (SSL_CIPHER*)SSL_get_current_cipher(ssl);
caml_leave_blocking_section();
if (!cipher)
caml_raise_constant(*caml_named_value("ssl_exn_cipher_error"));
CAMLreturn((value)cipher);
}
CAMLprim value unix_unlink(value path)
{
CAMLparam1(path);
char * p;
int ret;
p = caml_strdup(String_val(path));
caml_enter_blocking_section();
ret = unlink(p);
caml_leave_blocking_section();
caml_stat_free(p);
if (ret == -1) uerror("unlink", path);
CAMLreturn(Val_unit);
}
CAMLprim value unix_chmod(value path, value perm)
{
CAMLparam2(path, perm);
char * p;
int ret;
p = caml_strdup(String_val(path));
caml_enter_blocking_section();
ret = chmod(p, Int_val(perm));
caml_leave_blocking_section();
caml_stat_free(p);
if (ret == -1) uerror("chmod", path);
CAMLreturn(Val_unit);
}
CAMLprim value caml_sys_remove(value name)
{
CAMLparam1(name);
char * p;
int ret;
p = caml_strdup(String_val(name));
caml_enter_blocking_section();
ret = unlink(p);
caml_leave_blocking_section();
caml_stat_free(p);
if (ret != 0) caml_sys_error(name);
CAMLreturn(Val_unit);
}
CAMLprim value unix_chown(value path, value uid, value gid)
{
CAMLparam1(path);
char * p;
int ret;
p = caml_strdup(String_val(path));
caml_enter_blocking_section();
ret = chown(p, Int_val(uid), Int_val(gid));
caml_leave_blocking_section();
caml_stat_free(p);
if (ret == -1) uerror("chown", path);
CAMLreturn(Val_unit);
}
CAMLprim value unix_lseek_64(value fd, value ofs, value cmd)
{
file_offset ret;
/* [ofs] is an Int64, which is stored as a custom block; we must therefore
extract its contents before dropping the runtime lock, or it might be
moved. */
file_offset ofs_c = File_offset_val(ofs);
caml_enter_blocking_section();
ret = lseek(Int_val(fd), ofs_c, seek_command_table[Int_val(cmd)]);
caml_leave_blocking_section();
if (ret == -1) uerror("lseek", Nothing);
return Val_file_offset(ret);
}
CAMLprim value caml_sys_chdir(value dirname)
{
CAMLparam1(dirname);
char * p;
int ret;
p = caml_strdup(String_val(dirname));
caml_enter_blocking_section();
ret = chdir(p);
caml_leave_blocking_section();
caml_stat_free(p);
if (ret != 0) caml_sys_error(dirname);
CAMLreturn(Val_unit);
}
// Same as Faad.decode (Faad.Mp4.read_sample) but more efficient. Share code?
CAMLprim value ocaml_faad_mp4_decode(value m, value track, value sample, value dh)
{
CAMLparam4(m, track, sample, dh);
CAMLlocal1(outbuf);
mp4_t *mp = Mp4_val(m);
int t = Int_val(track);
int s = Int_val(sample);
NeAACDecHandle dec = Dec_val(dh);
NeAACDecFrameInfo frameInfo;
unsigned char *inbuf = NULL;
unsigned int inbuflen = 0;
float *data;
int c, i, ret;
caml_enter_blocking_section();
ret = mp4ff_read_sample(mp->ff, t, s, &inbuf, &inbuflen);
caml_leave_blocking_section();
check_err(ret);
caml_enter_blocking_section();
data = NeAACDecDecode(dec, &frameInfo, inbuf, inbuflen);
caml_leave_blocking_section();
free(inbuf);
if (!data)
caml_raise_constant(*caml_named_value("ocaml_faad_exn_failed"));
if (frameInfo.error != 0)
caml_raise_with_arg(*caml_named_value("ocaml_faad_exn_error"), Val_int(frameInfo.error));
outbuf = caml_alloc_tuple(frameInfo.channels);
for(c = 0; c < frameInfo.channels; c++)
Store_field(outbuf, c, caml_alloc(frameInfo.samples / frameInfo.channels * Double_wosize, Double_array_tag));
for(i = 0; i < frameInfo.samples; i++)
Store_double_field(Field(outbuf, i % frameInfo.channels), i / frameInfo.channels, data[i]);
CAMLreturn(outbuf);
}
CAMLprim value ocaml_faad_mp4_num_samples(value m, value track)
{
CAMLparam2(m, track);
mp4_t *mp = Mp4_val(m);
int t = Int_val(track);
int ans;
caml_enter_blocking_section();
ans = mp4ff_num_samples(mp->ff, t);
caml_leave_blocking_section();
CAMLreturn(Val_int(ans));
}
CAMLprim value netsys_poll_event_sources(value pav, value tmov)
{
#ifdef HAVE_POLL_AGGREG
struct poll_aggreg *pa;
int code;
int tmo;
int k;
int e;
#ifdef USABLE_EPOLL
struct epoll_event ee[EPOLL_NUM];
#endif
CAMLparam2(pav, tmov);
CAMLlocal3(r, r_item, r_cons);
tmo = Int_val(tmov);
pa = *(Poll_aggreg_val(pav));
#ifdef USABLE_EPOLL
caml_enter_blocking_section();
code = epoll_wait(pa->fd, ee, EPOLL_NUM, tmo);
e = errno;
caml_leave_blocking_section();
if (code == -1) unix_error(e, "epoll_wait", Nothing);
r = Val_int(0);
for (k=0; k<code; k++) {
if (ee[k].data.u64 == 1) { /* This is the reserved cancel_fd */
uint64_t buf;
int p;
p = read(pa->cancel_fd, (char *) &buf, 8);
}
else {
r_item = caml_alloc(3,0);
Store_field(r_item, 0, Val_long(ee[k].data.u64 >> 1));
Store_field(r_item, 1, Val_long(0)); /* i.e. mask = 0 */
Store_field(r_item, 2,
Val_int(translate_to_poll_events(ee[k].events)));
r_cons = caml_alloc(2,0);
Store_field(r_cons, 0, r_item);
Store_field(r_cons, 1, r);
r = r_cons;
}
};
#endif
CAMLreturn(r);
#else
invalid_argument("Netsys_posix.pull_event_sources not available");
#endif
}
static int dispatch_suspend(void *arg)
{
value * __suspend_closure;
int domid = (int) arg;
int ret;
__suspend_closure = caml_named_value("suspend_callback");
if (!__suspend_closure)
return 0;
caml_leave_blocking_section();
ret = Int_val(caml_callback(*__suspend_closure, Val_int(domid)));
caml_enter_blocking_section();
return ret;
}
CAMLprim value lwt_glib_iter(value may_block)
{
GMainContext *gc;
gint max_priority, timeout;
GPollFD *pollfds = NULL;
gint pollfds_size = 0;
gint nfds;
gint i;
/* Get the main context. */
gc = g_main_context_default();
/* Try to acquire it. */
if (!g_main_context_acquire(gc))
caml_failwith("Lwt_glib.iter");
/* Dispatch pending events. */
g_main_context_dispatch(gc);
/* Prepare the context for polling. */
g_main_context_prepare(gc, &max_priority);
/* Get all file descriptors to poll. */
while (pollfds_size < (nfds = g_main_context_query(gc, max_priority, &timeout, pollfds, pollfds_size))) {
free(pollfds);
pollfds_size = nfds;
pollfds = lwt_unix_malloc(pollfds_size * sizeof (GPollFD));
}
/* Clear all revents fields. */
for (i = 0; i < nfds; i++) pollfds[i].revents = 0;
/* Set the timeout to 0 if we do not want to block. */
if (!Bool_val(may_block)) timeout = 0;
/* Do the blocking call. */
caml_enter_blocking_section();
g_main_context_get_poll_func(gc)(pollfds, nfds, timeout);
caml_leave_blocking_section();
/* Let glib parse the result. */
g_main_context_check(gc, max_priority, pollfds, nfds);
/* Release the context. */
g_main_context_release(gc);
free(pollfds);
return Val_unit;
}
CAMLprim value unix_chroot(value path)
{
CAMLparam1(path);
char * p;
int ret;
caml_unix_check_path(path, "chroot");
p = caml_strdup(String_val(path));
caml_enter_blocking_section();
ret = chroot(p);
caml_leave_blocking_section();
caml_stat_free(p);
if (ret == -1) uerror("chroot", path);
CAMLreturn(Val_unit);
}
/* XXX: WARNING: this function leaks memory if v_ident is not None!
No way around that if syslog is called in a multi-threaded environment!
Therefore it shouldn't be called too often. What for, anyway? */
CAMLprim value openlog_stub(value v_ident, value v_option, value v_facility) {
char *ident = NULL; /* default to argv[0], as per syslog(3) */
if (v_ident != Val_none) {
int len = caml_string_length(Some_val(v_ident)) + 1;
ident = caml_stat_alloc(len);
memcpy(ident, String_val(Some_val(v_ident)), len);
}
caml_enter_blocking_section();
openlog(ident, Int_val(v_option), Int_val(v_facility));
/* openlog doesn't inter ident (if specified), so freeing it here
would create an invalid program. */
caml_leave_blocking_section();
return Val_unit;
}
CAMLprim value unix_posix_openpt(value flags)
{
CAMLparam1(flags);
int fd, cv_flags;
cv_flags = caml_convert_flag_list(flags, posix_openpt_flag_table);
caml_enter_blocking_section();
fd = posix_openpt(cv_flags);
caml_leave_blocking_section();
if (fd == -1) uerror("posix_openpt", Nothing);
CAMLreturn (Val_int(fd));
}
CAMLprim value unix_unlockpt(value mlfd)
{
CAMLparam1(mlfd);
int fd, err;
fd = Int_val(mlfd);
caml_enter_blocking_section();
err = unlockpt(fd);
caml_leave_blocking_section();
if (err == -1) uerror("unlockpt", Nothing);
CAMLreturn (Val_int(0));
}
