CAMLprim value ocaml_faad_mp4_open_read(value metaonly, value read, value write, value seek, value trunc)
{
CAMLparam4(read, write, seek, trunc);
CAMLlocal1(ans);
mp4_t *mp = malloc(sizeof(mp4_t));
mp->fd = -1;
mp->ff_cb.read = read_cb;
mp->read_cb = read;
caml_register_global_root(&mp->read_cb);
if (Is_block(write))
{
mp->ff_cb.write = write_cb;
mp->write_cb = Field(write, 0);
caml_register_global_root(&mp->write_cb);
}
else
{
mp->ff_cb.write = NULL;
mp->write_cb = 0;
}
if (Is_block(seek))
{
mp->ff_cb.seek = seek_cb;
mp->seek_cb = Field(seek, 0);
caml_register_global_root(&mp->seek_cb);
}
else
{
mp->ff_cb.seek = NULL;
mp->seek_cb = 0;
}
if (Is_block(trunc))
{
mp->ff_cb.truncate = trunc_cb;
mp->trunc_cb = Field(trunc, 0);
caml_register_global_root(&mp->trunc_cb);
}
else
{
mp->ff_cb.truncate = NULL;
mp->trunc_cb = 0;
}
mp->ff_cb.user_data = mp;
caml_enter_blocking_section();
if(Bool_val(metaonly))
mp->ff = mp4ff_open_read_metaonly(&mp->ff_cb);
else
mp->ff = mp4ff_open_read(&mp->ff_cb);
caml_leave_blocking_section();
assert(mp->ff);
ans = caml_alloc_custom(&mp4_ops, sizeof(mp4_t*), 1, 0);
Mp4_val(ans) = mp;
CAMLreturn(ans);
}
value caml_create_QQmlPropertyMap(value _func, value _unit) {
CAMLparam2(_func, _unit);
CAMLlocal1(_ans);
value *fv = (value*) malloc(sizeof(_func));
*fv = _func;
caml_register_global_root(fv);
CamlPropertyMap *propMap = new CamlPropertyMap();
_ans = caml_alloc_custom(&camlpropertymap_ops, sizeof(CamlPropertyMap*), 0, 1);
(*((CamlPropertyMap **) Data_custom_val(_ans))) = propMap;
propMap->saveCallback(fv);
QObject::connect(propMap, &CamlPropertyMap::valueChanged,
[fv](const QString& propName, const QVariant& var) {
caml_leave_blocking_section();
[&fv, &propName, &var]() {
CAMLparam0();
CAMLlocal2(_nameArg, _variantArg);
_nameArg = caml_copy_string( propName.toLocal8Bit().data() );
caml_callback2(*fv, _nameArg, Val_QVariant(_variantArg, var) );
CAMLreturn0;
}();
caml_enter_blocking_section();
} );
CAMLreturn(_ans);
}
value* fcl_wrap(value v)
{
value* res = malloc(sizeof(value*));
*res = v;
caml_register_global_root(res);
return res;
}
CAMLprim value
init_xtAddCallback(value v)
{
caml_xt_cb = v;
caml_register_global_root(&caml_xt_cb);
return Val_unit;
}
/* Guestfs.create */
CAMLprim value
ocaml_guestfs_create (void)
{
CAMLparam0 ();
CAMLlocal1 (gv);
guestfs_h *g;
value *v;
g = guestfs_create ();
if (g == NULL)
caml_failwith ("failed to create guestfs handle");
guestfs_set_error_handler (g, NULL, NULL);
gv = Val_guestfs (g);
/* Store the OCaml handle into the C handle. This is only so we can
* map the C handle to the OCaml handle in event_callback_wrapper.
*/
v = guestfs_safe_malloc (g, sizeof *v);
*v = gv;
/* XXX This global root is generational, but we cannot rely on every
* user having the OCaml 3.11 version which supports this.
*/
caml_register_global_root (v);
guestfs_set_private (g, "_ocaml_g", v);
CAMLreturn (gv);
}
/* Guestfs.set_event_callback */
CAMLprim value
ocaml_guestfs_set_event_callback (value gv, value closure, value events)
{
CAMLparam3 (gv, closure, events);
char key[64];
int eh;
uint64_t event_bitmask;
guestfs_h *g = Guestfs_val (gv);
event_bitmask = event_bitmask_of_event_list (events);
value *root = guestfs_safe_malloc (g, sizeof *root);
*root = closure;
eh = guestfs_set_event_callback (g, event_callback_wrapper,
event_bitmask, 0, root);
if (eh == -1) {
free (root);
ocaml_guestfs_raise_error (g, "set_event_callback");
}
/* XXX This global root is generational, but we cannot rely on every
* user having the OCaml 3.11 version which supports this.
*/
caml_register_global_root (root);
snprintf (key, sizeof key, "_ocaml_event_%d", eh);
guestfs_set_private (g, key, root);
CAMLreturn (Val_int (eh));
}
CAMLprim value sundials_ml_ida_init(value ida_solver, value ida_ctxt) {
CAMLparam2(ida_solver, ida_ctxt);
assert (Tag_val(ida_ctxt) == 0);
assert (Tag_val(Field(ida_ctxt, 0)) == Closure_tag);
assert (Tag_val(Field(ida_ctxt, 1)) == 0 );
assert (Tag_val(Field(Field(ida_ctxt, 1), 0)) == Double_tag );
IDA_CTXT(ida_solver) = ida_ctxt;
caml_register_global_root(&IDA_CTXT(ida_solver));
const realtype rt_t0 = Double_val(NUMSTATE_T0(ida_solver));
value y0 = NUMSTATE_YY(ida_solver);
value yp0 = NUMSTATE_YP(ida_solver);
BA_STACK_NVECTOR(y0, nv_y0);
BA_STACK_NVECTOR(yp0, nv_yp0);
value gi = Field(EVENTSTATE(ida_solver), 3);
const intnat ev_len = Caml_ba_array_val(gi)->dim[0];
const int ret = IDAInit(IDA_MEM(ida_solver), &sundials_ml_residual_wrapper, rt_t0, &nv_y0, &nv_yp0);
if (ev_len > 0) {
IDARootInit(IDA_MEM(ida_solver), ev_len, sundials_ml_event_wrapper);
}
CAMLreturn(Val_int(ret));
}
value *
ml_cairo_make_root (value v)
{
value *root = caml_stat_alloc (sizeof (value *));
*root = v;
caml_register_global_root (root);
return root;
}
paranode mk_root(value v) {
CAMLparam1(v);
paranode_t* p = (paranode_t*)malloc(sizeof(paranode_t));
caml_register_global_root(&(p->v));
p->v = v;
CAMLreturnT(paranode, p);
}
void caml_debugger_init(void)
{
char * address;
char * port, * p;
struct hostent * host;
int n;
caml_register_global_root(&marshal_flags);
marshal_flags = caml_alloc(2, Tag_cons);
Store_field(marshal_flags, 0, Val_int(1)); /* Marshal.Closures */
Store_field(marshal_flags, 1, Val_emptylist);
address = getenv("CAML_DEBUG_SOCKET");
if (address == NULL) return;
dbg_addr = address;
#ifdef _WIN32
winsock_startup();
(void)atexit(winsock_cleanup);
#endif
/* Parse the address */
port = NULL;
for (p = address; *p != 0; p++) {
if (*p == ':') { *p = 0; port = p+1; break; }
}
if (port == NULL) {
#ifndef _WIN32
/* Unix domain */
sock_domain = PF_UNIX;
sock_addr.s_unix.sun_family = AF_UNIX;
strncpy(sock_addr.s_unix.sun_path, address,
sizeof(sock_addr.s_unix.sun_path));
sock_addr_len =
((char *)&(sock_addr.s_unix.sun_path) - (char *)&(sock_addr.s_unix))
+ strlen(address);
#else
caml_fatal_error("Unix sockets not supported");
#endif
} else {
/* Internet domain */
sock_domain = PF_INET;
for (p = (char *) &sock_addr.s_inet, n = sizeof(sock_addr.s_inet);
n > 0; n--) *p++ = 0;
sock_addr.s_inet.sin_family = AF_INET;
sock_addr.s_inet.sin_addr.s_addr = inet_addr(address);
if (sock_addr.s_inet.sin_addr.s_addr == -1) {
host = gethostbyname(address);
if (host == NULL)
caml_fatal_error_arg("Unknown debugging host %s\n", address);
memmove(&sock_addr.s_inet.sin_addr, host->h_addr, host->h_length);
}
sock_addr.s_inet.sin_port = htons(atoi(port));
sock_addr_len = sizeof(sock_addr.s_inet);
}
open_connection();
caml_debugger_in_use = 1;
caml_trap_barrier = caml_stack_high;
}
PREFIX value ml_elm_naviframe_item_pop_cb_set(value v_it, value v_fun)
{
CAMLparam2(v_it, v_fun);
value* data = caml_stat_alloc(sizeof(value));
caml_register_global_root(data);
elm_naviframe_item_pop_cb_set((Elm_Object_Item*) v_it,
ml_Elm_Naviframe_Item_Pop_Cb, data);
CAMLreturn(Val_unit);
}
static value value_of_bus(GstBus *b)
{
if (!b) caml_raise_constant(*caml_named_value("gstreamer_exn_failure"));
value ans = caml_alloc_custom(&bus_ops, sizeof(bus_t*), 0, 1);
bus_t *bus = malloc(sizeof(bus));
bus->bus = b;
bus->element = 0;
caml_register_global_root(&bus->element);
Bus_data_val(ans) = bus;
return ans;
}
PREFIX value ml_evas_object_event_callback_add_mouse_down(
value v_obj, value v_func)
{
value* data = caml_stat_alloc(sizeof(value));
*data = v_func;
caml_register_global_root(data);
evas_object_event_callback_add((Evas_Object*) v_obj,
EVAS_CALLBACK_MOUSE_DOWN, ml_Evas_Object_Event_Cb_mouse_down,
data);
return Val_unit;
}
Hunpos hunpos_tagger_new(const char* model_file, const char* morph_table_file, int max_guessed_tags, int theta, int* error)
{
*error = 0;
if(model_file == NULL) {
*error = 3;
return NULL;
}
if(morph_table_file == NULL) {
morph_table_file = "";
}
/* Startup OCaml */
if (is_initialized == 0)
{
is_initialized = 1;
char* dummyargv[2];
dummyargv[0]="";
dummyargv[1]=NULL;
caml_startup(dummyargv);
}
CAMLparam0();
/* get hunpos init function from ocaml */
static value* init_fun;
if (init_fun == NULL)
{
init_fun = caml_named_value("init_from_files");
}
Hunpos tagger_fun = (Hunpos) malloc(sizeof(value));
*((value*)tagger_fun) = 0;
// we pass some argument to the function
CAMLlocalN ( args, 4 );
args[0] = caml_copy_string(model_file);
args[1] = caml_copy_string(morph_table_file);
args[2] = Val_int(max_guessed_tags);
args[3] = Val_int(theta);
/* due to the garbage collector we have to register the */
/* returned value not to be deallocated */
caml_register_global_root(tagger_fun);
value* t = tagger_fun;
*t = caml_callbackN_exn( *init_fun, 4, args );
if (Is_exception_result(*t))
{
*error = 1;
CAMLreturnT(Hunpos, NULL);
}
// CAMLreturn1(tagger_fun)
CAMLreturnT(Hunpos,tagger_fun);
}
PREFIX value ml_evas_object_smart_callback_add(
value v_obj, value v_event, value v_func)
{
CAMLparam3(v_obj, v_event, v_func);
value* data = caml_stat_alloc(sizeof(value));
*data = v_func;
caml_register_global_root(data);
const char* event = String_val(v_event);
evas_object_smart_callback_add((Evas_Object*) v_obj, event,
ml_Evas_Smart_Cb, data);
CAMLreturn(Val_unit);
}
CAMLprim value caml_record_backtrace(value vflag)
{
int flag = Int_val(vflag);
if (flag != caml_backtrace_active) {
caml_backtrace_active = flag;
caml_backtrace_pos = 0;
if (flag) {
caml_register_global_root(&caml_backtrace_last_exn);
} else {
caml_remove_global_root(&caml_backtrace_last_exn);
}
}
return Val_unit;
}
CAMLprim value ocaml_gstreamer_appsrc_connect_need_data(value _as, value f)
{
CAMLparam2(_as, f);
appsrc *as = Appsrc_val(_as);
disconnect_need_data(as);
caml_register_global_root(&as->need_data_cb);
caml_release_runtime_system();
as->need_data_cb = f;
as->need_data_hid = g_signal_connect(as->appsrc, "need-data", G_CALLBACK(appsrc_need_data_cb), as);
caml_acquire_runtime_system();
if(!as->need_data_hid) caml_raise_constant(*caml_named_value("gstreamer_exn_failure"));
CAMLreturn(Val_unit);
}
CAMLprim value ocaml_gstreamer_typefind_element_connect_have_type(value _tf, value f)
{
CAMLparam2(_tf, f);
typefind_element *tf = Typefind_element_data_val(_tf);
disconnect_have_type(tf);
tf->have_type_cb = f;
caml_register_global_root(&tf->have_type_cb);
caml_release_runtime_system();
tf->have_type_hid = g_signal_connect(tf->tf, "have-type", G_CALLBACK(typefind_element_have_type_cb), tf);
caml_acquire_runtime_system();
if (!tf->have_type_hid) caml_raise_constant(*caml_named_value("gstreamer_exn_failure"));
CAMLreturn(Val_unit);
}
CAMLprim value caml_install_signal_handler(value signal_number, value action)
{
CAMLparam2 (signal_number, action);
CAMLlocal1 (res);
int sig, act, oldact;
sig = caml_convert_signal_number(Int_val(signal_number));
if (sig < 0 || sig >= NSIG)
caml_invalid_argument("Sys.signal: unavailable signal");
switch(action) {
case Val_int(0): /* Signal_default */
act = 0;
break;
case Val_int(1): /* Signal_ignore */
act = 1;
break;
default: /* Signal_handle */
act = 2;
break;
}
oldact = caml_set_signal_action(sig, act);
switch (oldact) {
case 0: /* was Signal_default */
res = Val_int(0);
break;
case 1: /* was Signal_ignore */
res = Val_int(1);
break;
case 2: /* was Signal_handle */
res = caml_alloc_small (1, 0);
Field(res, 0) = Field(caml_signal_handlers, sig);
break;
default: /* error in caml_set_signal_action */
caml_sys_error(NO_ARG);
}
if (Is_block(action)) {
if (caml_signal_handlers == 0) {
caml_signal_handlers = caml_alloc(NSIG, 0);
caml_register_global_root(&caml_signal_handlers);
}
caml_modify(&Field(caml_signal_handlers, sig), Field(action, 0));
}
caml_process_pending_signals();
CAMLreturn (res);
}
CAMLprim value caml_record_backtrace(value vflag)
{
int flag = Int_val(vflag);
if (flag != caml_backtrace_active) {
caml_backtrace_active = flag;
caml_backtrace_pos = 0;
if (flag) {
caml_register_global_root(&caml_backtrace_last_exn);
} else {
caml_remove_global_root(&caml_backtrace_last_exn);
}
/* Note: lazy initialization of caml_backtrace_buffer in
caml_stash_backtrace to simplify the interface with the thread
libraries */
}
return Val_unit;
}
CAMLprim value ocaml_ssl_ctx_set_default_passwd_cb(value context, value cb)
{
CAMLparam2(context, cb);
SSL_CTX *ctx = Ctx_val(context);
value *pcb;
/* TODO: this never gets freed or even unregistered */
pcb = malloc(sizeof(value));
*pcb = cb;
caml_register_global_root(pcb);
caml_enter_blocking_section();
SSL_CTX_set_default_passwd_cb(ctx, pem_passwd_cb);
SSL_CTX_set_default_passwd_cb_userdata(ctx, pcb);
caml_leave_blocking_section();
CAMLreturn(Val_unit);
}
void ocamlpool_enter(void)
{
assert_out_of_section();
static int ocamlpool_initialized = 0;
if (ocamlpool_initialized == 0)
{
ocamlpool_initialized = 1;
caml_register_global_root(&ocamlpool_root);
}
if (ocamlpool_root != Val_unit)
ocamlpool_color = caml_allocation_color((void*)ocamlpool_root);
ocamlpool_in_section = 1;
ocamlpool_sane_young_ptr = caml_young_ptr;
assert_in_section();
}
static void
ml_sqlite3_register_big (value v)
{
CAMLparam1(v);
CAMLlocal1(c);
/* initialize */
if (big_root == 0)
{
big_root = Val_emptylist;
caml_register_global_root (&big_root);
}
/* prepend it to the list */
c = caml_alloc_small (2, Tag_cons);
Field (c, 0) = v;
Field (c, 1) = big_root;
big_root = c;
CAMLreturn0;
}
CAMLprim value caml_register_named_value(value vname, value val)
{
struct named_value * nv;
char * name = String_val(vname);
unsigned int h = hash_value_name(name);
for (nv = named_value_table[h]; nv != NULL; nv = nv->next) {
if (strcmp(name, nv->name) == 0) {
nv->val = val;
return Val_unit;
}
}
nv = (struct named_value *)
caml_stat_alloc(sizeof(struct named_value) + strlen(name));
strcpy(nv->name, name);
nv->val = val;
nv->next = named_value_table[h];
named_value_table[h] = nv;
caml_register_global_root(&nv->val);
return Val_unit;
}
/* Guestfs.create */
value
ocaml_guestfs_create (value environmentv, value close_on_exitv, value unitv)
{
CAMLparam3 (environmentv, close_on_exitv, unitv);
CAMLlocal1 (gv);
unsigned flags = 0;
guestfs_h *g;
value *v;
if (environmentv != Val_int (0) &&
!Bool_val (Field (environmentv, 0)))
flags |= GUESTFS_CREATE_NO_ENVIRONMENT;
if (close_on_exitv != Val_int (0) &&
!Bool_val (Field (close_on_exitv, 0)))
flags |= GUESTFS_CREATE_NO_CLOSE_ON_EXIT;
g = guestfs_create_flags (flags);
if (g == NULL)
caml_failwith ("failed to create guestfs handle");
guestfs_set_error_handler (g, NULL, NULL);
gv = Val_guestfs (g);
/* Store the OCaml handle into the C handle. This is only so we can
* map the C handle to the OCaml handle in event_callback_wrapper.
*/
v = guestfs_int_safe_malloc (g, sizeof *v);
*v = gv;
/* XXX This global root is generational, but we cannot rely on every
* user having the OCaml 3.11 version which supports this.
*/
caml_register_global_root (v);
guestfs_set_private (g, "_ocaml_g", v);
CAMLreturn (gv);
}
void caml_init_backtrace(void)
{
caml_register_global_root(&caml_backtrace_last_exn);
}
OCamlCallback( value closure_v ) {
m_closure = closure_v;
caml_register_global_root(&m_closure);
}
CAML_object::CAML_object(value v1) {
v = v1;
caml_register_global_root(&v);
}
void caml_init_exceptions(void)
{
out_of_memory_bucket.hdr = Make_header(1, 0, Caml_white);
out_of_memory_bucket.exn = Field(caml_global_data, OUT_OF_MEMORY_EXN);
caml_register_global_root(&out_of_memory_bucket.exn);
}
//-----------------------------------------------------------
QSingleFunc::QSingleFunc(value v) : _saved_callback(v)
{
caml_register_global_root(&_saved_callback);
}
