PREFIX value ml_elm_fileselector_selected_set(value v_obj, value v_path)
{
return Val_Eina_Bool(elm_fileselector_selected_set((Evas_Object*) v_obj,
String_val(v_path)));
}
static DWORD WINAPI gr_open_graph_internal(value arg)
{
RECT rc;
int ret;
int event;
int x, y, w, h;
int screenx,screeny;
int attributes;
static int registered;
MSG msg;
gr_initialized = TRUE;
hInst = GetModuleHandle(NULL);
x = y = w = h = CW_USEDEFAULT;
sscanf(String_val(arg), "%dx%d+%d+%d", &w, &h, &x, &y);
/* Open the display */
if (grwindow.hwnd == NULL || !IsWindow(grwindow.hwnd)) {
if (!registered) {
registered = DoRegisterClass();
if (!registered) {
open_graph_errmsg = "Cannot register the window class";
SetEvent(open_graph_event);
return 1;
}
}
grwindow.hwnd = CreateWindow(szOcamlWindowClass,
WINDOW_NAME,
WS_OVERLAPPEDWINDOW,
x,y,
w,h,
NULL,0,hInst,NULL);
if (grwindow.hwnd == NULL) {
open_graph_errmsg = "Cannot create window";
SetEvent(open_graph_event);
return 1;
}
#if 0
if (x != CW_USEDEFAULT) {
rc.left = 0;
rc.top = 0;
rc.right = w;
rc.bottom = h;
AdjustWindowRect(&rc,GetWindowLong(grwindow.hwnd,GWL_STYLE),0);
MoveWindow(grwindow.hwnd,x,y,rc.right-rc.left,rc.bottom-rc.top,1);
}
#endif
}
gr_reset();
ShowWindow(grwindow.hwnd,SW_SHOWNORMAL);
/* Position the current point at origin */
grwindow.grx = 0;
grwindow.gry = 0;
caml_gr_init_event_queue();
/* The global data structures are now correctly initialized.
Restart the Caml main thread. */
open_graph_errmsg = NULL;
SetEvent(open_graph_event);
/* Enter the message handling loop */
while (GetMessage(&msg,NULL,0,0)) {
TranslateMessage(&msg); // Translates virtual key codes
DispatchMessage(&msg); // Dispatches message to window
if (!IsWindow(grwindow.hwnd))
break;
}
return 0;
}
CAMLprim value caml_extunix_recvmsg2(value vfd, value vbuf, value ofs, value vlen,
value vflags)
{
CAMLparam4(vfd, vbuf, ofs, vlen);
CAMLlocal5(vres, vlist, v, vx, vsaddr);
union {
struct cmsghdr hdr;
char buf[CMSG_SPACE(sizeof(int)) /* File descriptor passing */
#ifdef EXTUNIX_HAVE_IP_RECVIF
+ CMSG_SPACE(sizeof(struct sockaddr_dl)) /* IP_RECVIF */
#endif
#ifdef EXTUNIX_HAVE_IP_RECVDSTADDR
+ CMSG_SPACE(sizeof(struct in_addr)) /* IP_RECVDSTADDR */
#endif
];
} cmsgbuf;
struct iovec iov;
struct msghdr msg;
struct cmsghdr *cmsg;
ssize_t n;
size_t len;
char iobuf[UNIX_BUFFER_SIZE];
struct sockaddr_storage ss;
int sendflags;
#ifdef EXTUNIX_HAVE_IP_RECVIF
struct sockaddr_dl *dst = NULL;
#endif
len = Long_val(vlen);
memset(&iov, 0, sizeof(iov));
memset(&msg, 0, sizeof(msg));
if (len > UNIX_BUFFER_SIZE)
len = UNIX_BUFFER_SIZE;
iov.iov_base = iobuf;
iov.iov_len = len;
msg.msg_name = &ss;
msg.msg_namelen = sizeof(ss);
msg.msg_iov = &iov;
msg.msg_iovlen = 1;
msg.msg_control = &cmsgbuf.buf;
msg.msg_controllen = sizeof(cmsgbuf.buf);
sendflags = caml_convert_flag_list(vflags, msg_flag_table);
caml_enter_blocking_section();
n = recvmsg(Int_val(vfd), &msg, sendflags);
caml_leave_blocking_section();
vres = caml_alloc_small(4, 0);
if (n == -1) {
uerror("recvmsg", Nothing);
CAMLreturn (vres);
}
vsaddr = my_alloc_sockaddr(&ss);
memmove(&Byte(vbuf, Long_val(ofs)), iobuf, n);
vlist = Val_int(0);
/* Build the variant list vlist */
for (cmsg = CMSG_FIRSTHDR(&msg); cmsg != NULL;
cmsg = CMSG_NXTHDR(&msg, cmsg)) {
if (cmsg->cmsg_level == SOL_SOCKET &&
cmsg->cmsg_type == SCM_RIGHTS) {
/* CMSG_DATA is aligned, so the following is cool */
v = caml_alloc_small(2, TAG_FILEDESCRIPTOR);
Field(v, 0) = Val_int(*(int *)CMSG_DATA(cmsg));
Field(v, 1) = vlist;
vlist = v;
continue;
}
#ifdef EXTUNIX_HAVE_IP_RECVIF
if (cmsg->cmsg_level == IPPROTO_IP &&
cmsg->cmsg_type == IP_RECVIF) {
dst = (struct sockaddr_dl *)CMSG_DATA(cmsg);
v = caml_alloc_small(2, 0);
vx = caml_alloc_small(1, TAG_IP_RECVIF);
Field(vx, 0) = Val_int(dst->sdl_index);
Field(v, 0) = vx;
Field(v, 1) = vlist;
vlist = v;
continue;
}
#endif
#ifdef EXTUNIX_HAVE_IP_RECVDSTADDR
if (cmsg->cmsg_level == IPPROTO_IP &&
cmsg->cmsg_type == IP_RECVDSTADDR) {
struct in_addr ipdst;
ipdst = *(struct in_addr *)CMSG_DATA(cmsg);
v = caml_alloc_small(2, 0);
vx = caml_alloc_small(1, TAG_IP_RECVDSTADDR);
Field(vx, 0) = caml_alloc_string(4);
memcpy(String_val(Field(vx, 0)), &ipdst, 4);
Field(v, 0) = vx;
Field(v, 1) = vlist;
vlist = v;
continue;
}
#endif
}
/* Now build the result */
Field(vres, 0) = Val_long(n);
Field(vres, 1) = vsaddr;
Field(vres, 2) = vlist;
Field(vres, 3) = int_to_recvflags(msg.msg_flags);
CAMLreturn(vres);
}
void hh_load(value in_filename) {
CAMLparam1(in_filename);
FILE* fp = fopen(String_val(in_filename), "rb");
if (fp == NULL) {
caml_failwith("Failed to open file");
}
uint64_t magic = 0;
read_all(fileno(fp), (void*)&magic, sizeof magic);
assert(magic == MAGIC_CONSTANT);
size_t revlen = 0;
read_all(fileno(fp), (void*)&revlen, sizeof revlen);
char revision[revlen];
read_all(fileno(fp), (void*)revision, revlen * sizeof(char));
assert(strncmp(revision, BuildInfo_kRevision, revlen) == 0);
read_all(fileno(fp), (void*)&heap_init_size, sizeof heap_init_size);
int compressed_size = 0;
read_all(fileno(fp), (void*)&compressed_size, sizeof compressed_size);
char* chunk_start = save_start();
pthread_attr_t attr;
pthread_attr_init(&attr);
pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_JOINABLE);
pthread_t thread;
decompress_args args;
int thread_started = 0;
// see hh_save for a description of what we are parsing here.
while (compressed_size > 0) {
char* compressed = malloc(compressed_size * sizeof(char));
assert(compressed != NULL);
uintptr_t chunk_size = 0;
read_all(fileno(fp), (void*)&chunk_size, sizeof chunk_size);
read_all(fileno(fp), compressed, compressed_size * sizeof(char));
if (thread_started) {
intptr_t success = 0;
int rc = pthread_join(thread, (void*)&success);
free(args.compressed);
assert(rc == 0);
assert(success);
}
args.compressed = compressed;
args.compressed_size = compressed_size;
args.decompress_start = chunk_start;
args.decompressed_size = chunk_size;
pthread_create(&thread, &attr, (void* (*)(void*))decompress, &args);
thread_started = 1;
chunk_start += chunk_size;
read_all(fileno(fp), (void*)&compressed_size, sizeof compressed_size);
}
if (thread_started) {
int success;
int rc = pthread_join(thread, (void*)&success);
free(args.compressed);
assert(rc == 0);
assert(success);
}
fclose(fp);
CAMLreturn0;
}
static unsigned long get_hash(value key) {
return *((unsigned long*)String_val(key));
}
CAMLextern_C value
caml_sfHttpRequest_setUri(value httpRequest, value uri)
{
SfHttpRequest_val(httpRequest)->setUri(String_val(uri));
return Val_unit;
}
value register_leds_cb(value cb_name) {
leds_closure = caml_named_value(String_val(cb_name));
return Val_unit;
}
/* string -> Target.t option */
CAMLprim value llvm_target_by_name(value Name) {
return llvm_target_option(LLVMGetTargetFromName(String_val(Name)));
}
/* string -> DataLayout.t */
CAMLprim value llvm_datalayout_of_string(value StringRep) {
return llvm_alloc_data_layout(LLVMCreateTargetData(String_val(StringRep)));
}
value setLeftCreatureName(str)
{
fi.leftName = (char*)(String_val(str));
return Val_unit;
}
value setRightCreatureName(str)
{
fi.rightName = (char*)(String_val(str));
return Val_unit;
}
value setRightCreatureTexture(str)
{
char* texture = (char*)(String_val(str));
sfSprite_SetImage(fi.rightCreature, TexturesManager_getTexture(game.texturesManager, texture));
return Val_unit;
}
/* Executes a pattern match with runtime options, a regular expression, a
string offset, a string length, a subject string, a number of subgroup
offsets, an offset vector and an optional callout function */
CAMLprim value pcre_exec_stub(value v_opt, value v_rex, value v_ofs,
value v_subj, value v_subgroups2, value v_ovec,
value v_maybe_cof)
{
const int ofs = Int_val(v_ofs), len = caml_string_length(v_subj);
if (ofs > len || ofs < 0)
caml_invalid_argument("Pcre.pcre_exec_stub: illegal offset");
{
const pcre *code = (pcre *) Field(v_rex, 1); /* Compiled pattern */
const pcre_extra *extra = (pcre_extra *) Field(v_rex, 2); /* Extra info */
const char *ocaml_subj = String_val(v_subj); /* Subject string */
const int opt = Int_val(v_opt); /* Runtime options */
int subgroups2 = Int_val(v_subgroups2);
const int subgroups2_1 = subgroups2 - 1;
const int subgroups3 = (subgroups2 >> 1) + subgroups2;
/* Special case when no callout functions specified */
if (v_maybe_cof == None) {
int *ovec = (int *) &Field(v_ovec, 0);
/* Performs the match */
const int ret =
pcre_exec(code, extra, ocaml_subj, len, ofs, opt, ovec, subgroups3);
if (ret < 0) {
switch(ret) {
case PCRE_ERROR_NOMATCH : caml_raise_constant(*pcre_exc_Not_found);
case PCRE_ERROR_PARTIAL : caml_raise_constant(*pcre_exc_Partial);
case PCRE_ERROR_MATCHLIMIT :
caml_raise_constant(*pcre_exc_MatchLimit);
case PCRE_ERROR_BADPARTIAL :
caml_raise_constant(*pcre_exc_BadPartial);
case PCRE_ERROR_BADUTF8 : caml_raise_constant(*pcre_exc_BadUTF8);
case PCRE_ERROR_BADUTF8_OFFSET :
caml_raise_constant(*pcre_exc_BadUTF8Offset);
default :
caml_raise_with_string(*pcre_exc_InternalError, "pcre_exec_stub");
}
}
else {
const int *ovec_src = ovec + subgroups2_1;
long int *ovec_dst = (long int *) ovec + subgroups2_1;
/* Converts offsets from C-integers to OCaml-Integers
This is a bit tricky, because there are 32- and 64-bit platforms
around and OCaml chooses the larger possibility for representing
integers when available (also in arrays) - not so the PCRE */
while (subgroups2--) {
*ovec_dst = Val_int(*ovec_src);
--ovec_src; --ovec_dst;
}
}
}
/* There are callout functions */
else {
value v_cof = Field(v_maybe_cof, 0);
value v_substrings;
char *subj = caml_stat_alloc(sizeof(char) * len);
int *ovec = caml_stat_alloc(sizeof(int) * subgroups3);
int ret;
struct cod cod = { (value *) NULL, (value *) NULL, (value) NULL };
struct pcre_extra new_extra =
#ifdef PCRE_CONFIG_MATCH_LIMIT_RECURSION
{ PCRE_EXTRA_CALLOUT_DATA, NULL, 0, NULL, NULL, 0 };
#else
{ PCRE_EXTRA_CALLOUT_DATA, NULL, 0, NULL, NULL };
#endif
memcpy(subj, ocaml_subj, len);
Begin_roots3(v_rex, v_cof, v_substrings);
Begin_roots2(v_subj, v_ovec);
v_substrings = caml_alloc_small(2, 0);
End_roots();
Field(v_substrings, 0) = v_subj;
Field(v_substrings, 1) = v_ovec;
cod.v_substrings_p = &v_substrings;
cod.v_cof_p = &v_cof;
new_extra.callout_data = &cod;
if (extra == NULL) {
ret = pcre_exec(code, &new_extra, subj, len, ofs, opt, ovec,
subgroups3);
}
else {
new_extra.flags = PCRE_EXTRA_CALLOUT_DATA | extra->flags;
new_extra.study_data = extra->study_data;
new_extra.match_limit = extra->match_limit;
new_extra.tables = extra->tables;
#ifdef PCRE_CONFIG_MATCH_LIMIT_RECURSION
new_extra.match_limit_recursion = extra->match_limit_recursion;
#endif
ret = pcre_exec(code, &new_extra, subj, len, ofs, opt, ovec,
subgroups3);
}
free(subj);
End_roots();
if (ret < 0) {
free(ovec);
switch(ret) {
case PCRE_ERROR_NOMATCH : caml_raise_constant(*pcre_exc_Not_found);
case PCRE_ERROR_PARTIAL : caml_raise_constant(*pcre_exc_Partial);
case PCRE_ERROR_MATCHLIMIT :
caml_raise_constant(*pcre_exc_MatchLimit);
case PCRE_ERROR_BADPARTIAL :
caml_raise_constant(*pcre_exc_BadPartial);
case PCRE_ERROR_BADUTF8 : caml_raise_constant(*pcre_exc_BadUTF8);
case PCRE_ERROR_BADUTF8_OFFSET :
caml_raise_constant(*pcre_exc_BadUTF8Offset);
case PCRE_ERROR_CALLOUT : caml_raise(cod.v_exn);
default :
caml_raise_with_string(*pcre_exc_InternalError, "pcre_exec_stub");
}
}
else {
int *ovec_src = ovec + subgroups2_1;
long int *ovec_dst = &Field(v_ovec, 0) + subgroups2_1;
while (subgroups2--) {
*ovec_dst = Val_int(*ovec_src);
--ovec_src; --ovec_dst;
}
free(ovec);
}
}
}
return Val_unit;
}
/* Byte-code hook for pcre_exec_stub
Needed, because there are more than 5 arguments */
CAMLprim value pcre_exec_stub_bc(value *argv, int __unused argn)
{
return pcre_exec_stub(argv[0], argv[1], argv[2], argv[3],
argv[4], argv[5], argv[6]);
}
/* Generates a new set of chartables for the current locale (see man
page of PCRE */
CAMLprim value pcre_maketables_stub(value __unused v_unit)
{
/* GC will do a full cycle every 100 table set allocations
(one table set consumes 864 bytes -> maximum of 86400 bytes
unreclaimed table sets) */
const value v_res = caml_alloc_final(2, pcre_dealloc_tables, 864, 86400);
Field(v_res, 1) = (value) pcre_maketables();
return v_res;
}
/* Wraps around the isspace-function */
CAMLprim value pcre_isspace_stub(value v_c)
{
return Val_bool(isspace(Int_val(v_c)));
}
/* Returns number of substring associated with a name */
CAMLprim value pcre_get_stringnumber_stub(value v_rex, value v_name)
{
const int ret = pcre_get_stringnumber((pcre *) Field(v_rex, 1),
String_val(v_name));
if (ret == PCRE_ERROR_NOSUBSTRING)
caml_invalid_argument("Named string not found");
return Val_int(ret);
}
/* Returns array of names of named substrings in a regexp */
CAMLprim value pcre_names_stub(value v_rex)
{
CAMLparam0();
CAMLlocal1(v_res);
int name_count;
int entry_size;
const char *tbl_ptr;
int i;
int ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMECOUNT, &name_count);
if (ret != 0)
caml_raise_with_string(*pcre_exc_InternalError, "pcre_names_stub");
ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMEENTRYSIZE, &entry_size);
if (ret != 0)
caml_raise_with_string(*pcre_exc_InternalError, "pcre_names_stub");
ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMETABLE, &tbl_ptr);
if (ret != 0)
caml_raise_with_string(*pcre_exc_InternalError, "pcre_names_stub");
v_res = caml_alloc(name_count, 0);
for (i = 0; i < name_count; ++i) {
value v_name = caml_copy_string(tbl_ptr + 2);
Store_field(v_res, i, v_name);
tbl_ptr += entry_size;
}
CAMLreturn(v_res);
}
static void extern_rec(value v)
{
struct code_fragment * cf;
struct extern_item * sp;
sp = extern_stack;
while(1) {
if (Is_long(v)) {
intnat n = Long_val(v);
if (n >= 0 && n < 0x40) {
Write(PREFIX_SMALL_INT + n);
} else if (n >= -(1 << 7) && n < (1 << 7)) {
writecode8(CODE_INT8, n);
} else if (n >= -(1 << 15) && n < (1 << 15)) {
writecode16(CODE_INT16, n);
#ifdef ARCH_SIXTYFOUR
} else if (n < -((intnat)1 << 31) || n >= ((intnat)1 << 31)) {
writecode64(CODE_INT64, n);
#endif
} else
writecode32(CODE_INT32, n);
goto next_item;
}
if (Is_in_value_area(v)) {
header_t hd = Hd_val(v);
tag_t tag = Tag_hd(hd);
mlsize_t sz = Wosize_hd(hd);
if (tag == Forward_tag) {
value f = Forward_val (v);
if (Is_block (f)
&& (!Is_in_value_area(f) || Tag_val (f) == Forward_tag
|| Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag)){
/* Do not short-circuit the pointer. */
}else{
v = f;
continue;
}
}
/* Atoms are treated specially for two reasons: they are not allocated
in the externed block, and they are automatically shared. */
if (sz == 0) {
if (tag < 16) {
Write(PREFIX_SMALL_BLOCK + tag);
} else {
writecode32(CODE_BLOCK32, hd);
}
goto next_item;
}
/* Check if already seen */
if (Color_hd(hd) == Caml_blue) {
uintnat d = obj_counter - (uintnat) Field(v, 0);
if (d < 0x100) {
writecode8(CODE_SHARED8, d);
} else if (d < 0x10000) {
writecode16(CODE_SHARED16, d);
} else {
writecode32(CODE_SHARED32, d);
}
goto next_item;
}
/* Output the contents of the object */
switch(tag) {
case String_tag: {
mlsize_t len = caml_string_length(v);
if (len < 0x20) {
Write(PREFIX_SMALL_STRING + len);
} else if (len < 0x100) {
writecode8(CODE_STRING8, len);
} else {
writecode32(CODE_STRING32, len);
}
writeblock(String_val(v), len);
size_32 += 1 + (len + 4) / 4;
size_64 += 1 + (len + 8) / 8;
extern_record_location(v);
break;
}
case Double_tag: {
if (sizeof(double) != 8)
extern_invalid_argument("output_value: non-standard floats");
Write(CODE_DOUBLE_NATIVE);
writeblock_float8((double *) v, 1);
size_32 += 1 + 2;
size_64 += 1 + 1;
extern_record_location(v);
break;
}
case Double_array_tag: {
mlsize_t nfloats;
if (sizeof(double) != 8)
extern_invalid_argument("output_value: non-standard floats");
nfloats = Wosize_val(v) / Double_wosize;
if (nfloats < 0x100) {
writecode8(CODE_DOUBLE_ARRAY8_NATIVE, nfloats);
} else {
writecode32(CODE_DOUBLE_ARRAY32_NATIVE, nfloats);
}
writeblock_float8((double *) v, nfloats);
size_32 += 1 + nfloats * 2;
size_64 += 1 + nfloats;
extern_record_location(v);
break;
}
case Abstract_tag:
extern_invalid_argument("output_value: abstract value (Abstract)");
break;
case Infix_tag:
writecode32(CODE_INFIXPOINTER, Infix_offset_hd(hd));
extern_rec(v - Infix_offset_hd(hd));
break;
case Custom_tag: {
uintnat sz_32, sz_64;
char * ident = Custom_ops_val(v)->identifier;
void (*serialize)(value v, uintnat * wsize_32,
uintnat * wsize_64)
= Custom_ops_val(v)->serialize;
if (serialize == NULL)
extern_invalid_argument("output_value: abstract value (Custom)");
Write(CODE_CUSTOM);
writeblock(ident, strlen(ident) + 1);
Custom_ops_val(v)->serialize(v, &sz_32, &sz_64);
size_32 += 2 + ((sz_32 + 3) >> 2); /* header + ops + data */
size_64 += 2 + ((sz_64 + 7) >> 3);
extern_record_location(v);
break;
}
default: {
value field0;
if (tag < 16 && sz < 8) {
Write(PREFIX_SMALL_BLOCK + tag + (sz << 4));
#ifdef ARCH_SIXTYFOUR
} else if (hd >= ((uintnat)1 << 32)) {
writecode64(CODE_BLOCK64, Whitehd_hd (hd));
#endif
} else {
writecode32(CODE_BLOCK32, Whitehd_hd (hd));
}
size_32 += 1 + sz;
size_64 += 1 + sz;
field0 = Field(v, 0);
extern_record_location(v);
/* Remember that we still have to serialize fields 1 ... sz - 1 */
if (sz > 1) {
sp++;
if (sp >= extern_stack_limit) sp = extern_resize_stack(sp);
sp->v = &Field(v,1);
sp->count = sz-1;
}
/* Continue serialization with the first field */
v = field0;
continue;
}
}
}
else if ((cf = extern_find_code((char *) v)) != NULL) {
if (!extern_closures)
extern_invalid_argument("output_value: functional value");
writecode32(CODE_CODEPOINTER, (char *) v - cf->code_start);
writeblock((char *) cf->digest, 16);
} else {
extern_invalid_argument("output_value: abstract value (outside heap)");
}
next_item:
/* Pop one more item to marshal, if any */
if (sp == extern_stack) {
/* We are done. Cleanup the stack and leave the function */
extern_free_stack();
return;
}
v = *((sp->v)++);
if (--(sp->count) == 0) sp--;
}
CAMLprim value caml_sys_rename(value oldname, value newname)
{
if (rename(String_val(oldname), String_val(newname)) != 0)
caml_sys_error(NO_ARG);
return Val_unit;
}
CAMLprim value mmdb_ml_lookup_path(value ip, value query_list, value mmdb)
{
CAMLparam3(ip, query_list, mmdb);
CAMLlocal3(iter_count, caml_clean_result, query_r);
int total_len = 0, copy_count = 0, gai_error = 0, mmdb_error = 0;
char *clean_result;
long int int_result;
iter_count = query_list;
unsigned int len = caml_string_length(ip);
char *as_string = caml_strdup(String_val(ip));
if (strlen(as_string) != (size_t)len) {
caml_failwith("Could not copy IP address properly");
}
MMDB_s *as_mmdb = (MMDB_s*)Data_custom_val(mmdb);
MMDB_lookup_result_s *result = caml_stat_alloc(sizeof(*result));
*result = MMDB_lookup_string(as_mmdb, as_string, &gai_error, &mmdb_error);
check_error(gai_error, mmdb_error);
caml_stat_free(as_string);
while (iter_count != Val_emptylist) {
total_len++;
iter_count = Field(iter_count, 1);
}
char **query = caml_stat_alloc(sizeof(char *) * (total_len + 1));
while (query_list != Val_emptylist) {
query[copy_count] = caml_strdup(String_val(Field(query_list, 0)));
copy_count++;
query_list = Field(query_list, 1);
}
query[total_len] = NULL;
MMDB_entry_data_s entry_data;
int status = MMDB_aget_value(&result->entry,
&entry_data,
(const char *const *const)query);
check_status(status);
check_data(entry_data);
caml_stat_free(result);
for (int i = 0; i < copy_count; caml_stat_free(query[i]), i++);
caml_stat_free(query);
query_r = caml_alloc(2, 0);
as_mmdb = NULL;
switch (entry_data.type) {
case MMDB_DATA_TYPE_BYTES:
clean_result = caml_stat_alloc(entry_data.data_size + 1);
memcpy(clean_result, entry_data.bytes, entry_data.data_size);
caml_clean_result = caml_copy_string(clean_result);
caml_stat_free(clean_result);
goto string_finish;
case MMDB_DATA_TYPE_UTF8_STRING:
clean_result = strndup(entry_data.utf8_string, entry_data.data_size);
caml_clean_result = caml_copy_string(clean_result);
free(clean_result);
goto string_finish;
case MMDB_DATA_TYPE_FLOAT:
Store_field(query_r, 0, polymorphic_variants.poly_float);
Store_field(query_r, 1, caml_copy_double(entry_data.float_value));
goto finish;
case MMDB_DATA_TYPE_BOOLEAN:
Store_field(query_r, 0, polymorphic_variants.poly_bool);
Store_field(query_r, 1, Val_true ? entry_data.boolean : Val_false);
goto finish;
case MMDB_DATA_TYPE_DOUBLE:
Store_field(query_r, 0, polymorphic_variants.poly_float);
Store_field(query_r, 1, caml_copy_double(entry_data.double_value));
goto finish;
case MMDB_DATA_TYPE_UINT16:
Store_field(query_r, 0, polymorphic_variants.poly_int);
int_result = Val_long(entry_data.uint16);
goto int_finish;
case MMDB_DATA_TYPE_UINT32:
Store_field(query_r, 0, polymorphic_variants.poly_int);
int_result = Val_long(entry_data.uint32);
goto int_finish;
case MMDB_DATA_TYPE_UINT64:
Store_field(query_r, 0, polymorphic_variants.poly_int);
int_result = Val_long(entry_data.uint32);
goto int_finish;
// look at /usr/bin/sed -n 1380,1430p src/maxminddb.c
case MMDB_DATA_TYPE_ARRAY:
case MMDB_DATA_TYPE_MAP:
caml_failwith("Can't return a Map or Array yet");
}
string_finish:
Store_field(query_r, 0, polymorphic_variants.poly_string);
Store_field(query_r, 1, caml_clean_result);
CAMLreturn(query_r);
int_finish:
Store_field(query_r, 1, int_result);
CAMLreturn(query_r);
finish:
CAMLreturn(query_r);
}
CAMLprim value caml_sys_chdir(value dirname)
{
if (chdir(String_val(dirname)) != 0) caml_sys_error(dirname);
return Val_unit;
}
CAMLprim value unix_link_r(CAML_R, value path1, value path2)
{
if (link(String_val(path1), String_val(path2)) == -1) uerror_r(ctx,"link", path2);
return Val_unit;
}
CAMLextern_C value
caml_sfHttpRequest_setBody(value httpRequest, value body)
{
SfHttpRequest_val(httpRequest)->setBody(String_val(body));
return Val_unit;
}
char *ifname = String_val(caml_ifname); \
struct ifreq ifr; \
\
memset(&ifr, 0, sizeof(struct ifreq)); \
copyifname(ifr.ifr_name, ifname); \
SETTER; \
FI(socket, REQUEST, &ifr); \
RESULT(Val_unit, 0); \
}
SET_FIELD(SIOCSIFFLAGS, siocsifflags_c, ifr.ifr_flags = Int_val(caml_val))
SET_FIELD(SIOCSIFPFLAGS, siocsifpflags_c, ifr.ifr_flags = Int_val(caml_val))
SET_FIELD(SIOCSIFMTU, siocsifmtu_c, ifr.ifr_mtu = Int_val(caml_val))
SET_FIELD(SIOCSIFTXQLEN, siocsiftxqlen_c, ifr.ifr_qlen = Int_val(caml_val))
SET_FIELD(SIOCSIFNAME, siocsifname_c, copyifname(ifr.ifr_newname, String_val(caml_val)))
static void
set_hwaddr(struct sockaddr *sa, value hwaddr)
{
/* quick and dirty checks */
if (caml_string_length(hwaddr) != ETHERNET_MAC_LEN) caml_failwith("Expected 6 byte ethernet MAC");
memcpy(sa->sa_data, String_val(hwaddr), ETHERNET_MAC_LEN);
return;
}
SET_FIELD(SIOCSIFHWADDR, siocsifhwaddr_c, set_hwaddr(&ifr.ifr_hwaddr, caml_val))
static void
set_ipaddr(struct sockaddr *sa, value ipaddr)
{
static void extern_rec(value v)
{
tailcall:
if (Is_long(v)) {
intnat n = Long_val(v);
if (n >= 0 && n < 0x40) {
Write(PREFIX_SMALL_INT + n);
} else if (n >= -(1 << 7) && n < (1 << 7)) {
writecode8(CODE_INT8, n);
} else if (n >= -(1 << 15) && n < (1 << 15)) {
writecode16(CODE_INT16, n);
#ifdef ARCH_SIXTYFOUR
} else if (n < -((intnat)1 << 31) || n >= ((intnat)1 << 31)) {
writecode64(CODE_INT64, n);
#endif
} else
writecode32(CODE_INT32, n);
return;
}
if (Is_young(v) || Is_in_heap(v) || Is_atom(v)) {
header_t hd = Hd_val(v);
tag_t tag = Tag_hd(hd);
mlsize_t sz = Wosize_hd(hd);
if (tag == Forward_tag) {
value f = Forward_val (v);
if (Is_block (f) && (Is_young (f) || Is_in_heap (f))
&& (Tag_val (f) == Forward_tag || Tag_val (f) == Lazy_tag
|| Tag_val (f) == Double_tag)){
/* Do not short-circuit the pointer. */
}else{
v = f;
goto tailcall;
}
}
/* Atoms are treated specially for two reasons: they are not allocated
in the externed block, and they are automatically shared. */
if (sz == 0) {
if (tag < 16) {
Write(PREFIX_SMALL_BLOCK + tag);
} else {
writecode32(CODE_BLOCK32, hd);
}
return;
}
/* Check if already seen */
if (Color_hd(hd) == Caml_blue) {
uintnat d = obj_counter - (uintnat) Field(v, 0);
if (d < 0x100) {
writecode8(CODE_SHARED8, d);
} else if (d < 0x10000) {
writecode16(CODE_SHARED16, d);
} else {
writecode32(CODE_SHARED32, d);
}
return;
}
/* Output the contents of the object */
switch(tag) {
case String_tag: {
mlsize_t len = caml_string_length(v);
if (len < 0x20) {
Write(PREFIX_SMALL_STRING + len);
} else if (len < 0x100) {
writecode8(CODE_STRING8, len);
} else {
writecode32(CODE_STRING32, len);
}
writeblock(String_val(v), len);
size_32 += 1 + (len + 4) / 4;
size_64 += 1 + (len + 8) / 8;
extern_record_location(v);
break;
}
case Double_tag: {
if (sizeof(double) != 8)
extern_invalid_argument("output_value: non-standard floats");
Write(CODE_DOUBLE_NATIVE);
writeblock_float8((double *) v, 1);
size_32 += 1 + 2;
size_64 += 1 + 1;
extern_record_location(v);
break;
}
case Double_array_tag: {
mlsize_t nfloats;
if (sizeof(double) != 8)
extern_invalid_argument("output_value: non-standard floats");
nfloats = Wosize_val(v) / Double_wosize;
if (nfloats < 0x100) {
writecode8(CODE_DOUBLE_ARRAY8_NATIVE, nfloats);
} else {
writecode32(CODE_DOUBLE_ARRAY32_NATIVE, nfloats);
}
writeblock_float8((double *) v, nfloats);
size_32 += 1 + nfloats * 2;
size_64 += 1 + nfloats;
extern_record_location(v);
break;
}
case Abstract_tag:
extern_invalid_argument("output_value: abstract value (Abstract)");
break;
case Infix_tag:
writecode32(CODE_INFIXPOINTER, Infix_offset_hd(hd));
extern_rec(v - Infix_offset_hd(hd));
break;
case Custom_tag: {
uintnat sz_32, sz_64;
char * ident = Custom_ops_val(v)->identifier;
void (*serialize)(value v, uintnat * wsize_32,
uintnat * wsize_64)
= Custom_ops_val(v)->serialize;
if (serialize == NULL)
extern_invalid_argument("output_value: abstract value (Custom)");
Write(CODE_CUSTOM);
writeblock(ident, strlen(ident) + 1);
Custom_ops_val(v)->serialize(v, &sz_32, &sz_64);
size_32 += 2 + ((sz_32 + 3) >> 2); /* header + ops + data */
size_64 += 2 + ((sz_64 + 7) >> 3);
extern_record_location(v);
break;
}
default: {
value field0;
mlsize_t i;
if (tag < 16 && sz < 8) {
Write(PREFIX_SMALL_BLOCK + tag + (sz << 4));
#ifdef ARCH_SIXTYFOUR
} else if (hd >= ((uintnat)1 << 32)) {
writecode64(CODE_BLOCK64, Whitehd_hd (hd));
#endif
} else {
writecode32(CODE_BLOCK32, Whitehd_hd (hd));
}
size_32 += 1 + sz;
size_64 += 1 + sz;
field0 = Field(v, 0);
extern_record_location(v);
if (sz == 1) {
v = field0;
} else {
extern_rec(field0);
for (i = 1; i < sz - 1; i++) extern_rec(Field(v, i));
v = Field(v, i);
}
goto tailcall;
}
}
}
value read_dump_file(value filename) {
CAMLparam1(filename);
CAMLlocal5(ocaml_var, ocaml_list_el1, ocaml_list_el2,
ocaml_dyn_type, ocaml_dyn_aux);
CAMLlocal2(ocaml_name, ocaml_hostval);
printf("opening %s\n", String_val(filename));
FILE *ifile = fopen(String_val(filename), "r");
if (ifile == NULL) {
ocaml_var = Val_int(0);
CAMLreturn(ocaml_var);
}
int num_vars = 0;
fread(&num_vars, sizeof(int), 1, ifile);
if (num_vars == 0) {
ocaml_var = Val_int(0);
CAMLreturn(ocaml_var);
}
printf("parsing vars\n");
ocaml_list_el2 = caml_alloc_tuple(2);
int i, j;
int name_len, shape_len, type, num_bytes;
int *shape;
char *name, *data;
for (i = 0; i < num_vars; ++i) {
// Allocate the variable tuple of (name, hostval)
ocaml_var = caml_alloc_tuple(2);
// Build the name
fread(&name_len, sizeof(int), 1, ifile);
ocaml_name = caml_alloc_string(name_len);
fread(String_val(ocaml_name), sizeof(char), name_len, ifile);
Store_field(ocaml_var, 0, ocaml_name);
printf("got var name: %s\n", String_val(ocaml_name));
// Build the shape
fread(&shape_len, sizeof(int), 1, ifile);
shape = (int*)malloc(shape_len * sizeof(int));
fread(shape, sizeof(int), shape_len, ifile);
printf("got shape of len %d\n", shape_len);
// Build the DynType
fread(&ocaml_dyn_type, sizeof(value), 1, ifile);
for (j = 0; j < shape_len; ++j) {
ocaml_dyn_aux = ocaml_dyn_type;
ocaml_dyn_type = caml_alloc(1, VecT);
Store_field(ocaml_dyn_type, 0, ocaml_dyn_aux);
}
printf("built dyn_type\n");
// Get the num_bytes
fread(&num_bytes, sizeof(int), 1, ifile);
// Get the payload
data = (char*)malloc(num_bytes);
fread(data, 1, num_bytes, ifile);
printf("got payload of %d bytes\n", num_bytes);
// Build the HostVal
ocaml_hostval = build_ocaml_hostval(num_bytes, ocaml_dyn_type,
shape, shape_len, data);
printf("built hostval from inputs\n");
Store_field(ocaml_var, 1, ocaml_hostval);
// Insert the var into the list
if (i == 0) {
Store_field(ocaml_list_el2, 1, Val_int(0));
} else {
Store_field(ocaml_list_el2, 1, ocaml_list_el1);
}
Store_field(ocaml_list_el2, 0, ocaml_var);
if (i < num_vars - 1) {
ocaml_list_el1 = ocaml_list_el2;
ocaml_list_el2 = caml_alloc_tuple(2);
}
}
fclose(ifile);
CAMLreturn(ocaml_list_el2);
}
static char* hh_store_ocaml(value data) {
size_t data_size = caml_string_length(data);
char* addr = hh_alloc(data_size);
memcpy(addr, String_val(data), data_size);
return addr;
}
value xdiff_revpatch( value old_data, value patch)
{
CAMLparam2 (old_data, patch);
CAMLlocal1(res);
mmfile_t mf1, mf2, mf3, mf4;
xdemitcb_t ecb, rjecb;
long new_size, rej_size;
res = alloc_tuple(2);
if (xdlt_store_mmfile(String_val(old_data), string_length(old_data), &mf1) < 0) {
sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__);
failwith(ELINE);
}
if (xdlt_store_mmfile(String_val(patch), string_length(patch), &mf2) < 0) {
xdl_free_mmfile(&mf1);
sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__);
failwith(ELINE);
}
if (xdl_init_mmfile(&mf3, XDLT_STD_BLKSIZE, XDL_MMF_ATOMIC) < 0) {
xdl_free_mmfile(&mf1);
xdl_free_mmfile(&mf2);
sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__);
failwith(ELINE);
}
if (xdl_init_mmfile(&mf4, XDLT_STD_BLKSIZE, XDL_MMF_ATOMIC) < 0) {
xdl_free_mmfile(&mf1);
xdl_free_mmfile(&mf2);
xdl_free_mmfile(&mf3);
sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__);
failwith(ELINE);
}
ecb.priv = &mf3;
ecb.outf = xdlt_outf;
rjecb.priv = &mf4;
rjecb.outf = xdlt_outf;
if (xdl_patch(&mf1, &mf2, XDL_PATCH_REVERSE, &ecb, &rjecb) < 0) {
xdl_free_mmfile(&mf1);
xdl_free_mmfile(&mf2);
xdl_free_mmfile(&mf3);
xdl_free_mmfile(&mf4);
sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__);
failwith(ELINE);
}
new_size = xdlt_mmfile_size(&mf3);
rej_size = xdlt_mmfile_size(&mf4);
Field(res, 0) = alloc_string(new_size);
Field(res, 1) = alloc_string(rej_size);
if (xdlt_read_mmfile(String_val(Field(res, 0)), &mf3) < 0) {
xdl_free_mmfile(&mf1);
xdl_free_mmfile(&mf2);
xdl_free_mmfile(&mf3);
xdl_free_mmfile(&mf4);
sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__);
failwith(ELINE);
}
if (xdlt_read_mmfile(String_val(Field(res, 1)), &mf4) < 0) {
xdl_free_mmfile(&mf1);
xdl_free_mmfile(&mf2);
xdl_free_mmfile(&mf3);
xdl_free_mmfile(&mf4);
sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__);
failwith(ELINE);
}
xdl_free_mmfile(&mf1);
xdl_free_mmfile(&mf2);
xdl_free_mmfile(&mf3);
xdl_free_mmfile(&mf4);
CAMLreturn(res);
}
CAMLprim value unix_unlink(value path)
{
if (unlink(String_val(path)) == -1) uerror("unlink", path);
return Val_unit;
}
/* given a return value in OCaml land, translate it to
the return_val_t C structure
*/
return_val_t translate_return_value(value ocaml_result) {
CAMLparam1(ocaml_result);
CAMLlocal5(ocaml_shape, ocaml_strides, ocaml_data, ocaml_cur, ocaml_type);
CAMLlocal1(v);
return_val_t ret;
if (Is_long(ocaml_result)) {
// In this case, we know that the return code must have been Pass,
// since the other two return codes have data.
ret.return_code = RET_PASS;
ret.results_len = 0;
} else if (Tag_val(ocaml_result) == RET_FAIL) {
ret.return_code = RET_FAIL;
ret.results_len = caml_string_length(Field(ocaml_result, 0));
ret.error_msg = malloc(ret.results_len + 1);
strcpy(ret.error_msg, String_val(Field(ocaml_result, 0)));
} else if (Tag_val(ocaml_result) == RET_SUCCESS) {
ocaml_cur = Field(ocaml_result, 0);
ret.return_code = RET_SUCCESS;
ret.results_len = ocaml_list_length(ocaml_cur);
ret.results = (ret_t*)malloc(sizeof(ret_t) * ret.results_len);
int i, j;
host_val h;
for (i = 0; i < ret.results_len; ++i) {
v = Field(ocaml_cur, 0);
h = create_host_val(v);
ocaml_cur = Field(ocaml_cur, 1);
// returning a scalar
if (value_is_scalar(h)) {
ret.results[i].is_scalar = 1;
ocaml_type = (scalar_type)value_type_of(h);
ret.results[i].data.scalar.ret_type =
get_scalar_element_type(ocaml_type);
// WARNING:
// Tiny Memory Leak Ahead
// -----------------------
// When scalar data is returned to the host language
// on the heap, it should be manually deleted by the
// host frontend
if (type_is_bool(ocaml_type)) {
ret.results[i].data.scalar.ret_scalar_value.boolean = get_bool(h);
} else if (type_is_int32(ocaml_type)) {
ret.results[i].data.scalar.ret_scalar_value.int32 = get_int32(h);
} else if (type_is_int64(ocaml_type)) {
ret.results[i].data.scalar.ret_scalar_value.int64 = get_int64(h);
} else if (type_is_float32(ocaml_type)) {
ret.results[i].data.scalar.ret_scalar_value.float32 = get_float64(h);
} else if (type_is_float64(ocaml_type)) {
ret.results[i].data.scalar.ret_scalar_value.float64 = get_float64(h);
} else {
caml_failwith("Unable to return scalar of this type\n");
}
} else {
// Pass the type
ret.results[i].is_scalar = 0;
ret.results[i].data.array.ret_type = array_type_of(h);
// Pass the data
ret.results[i].data.array.data = get_array_data(h);
// Build the shape array
ocaml_shape = value_get_shape(h);
int shape_len = Wosize_val(ocaml_shape);
ret.results[i].data.array.shape =
(int*)malloc(shape_len * sizeof(int));
ret.results[i].data.array.shape_len = shape_len;
for (j = 0; j < shape_len; ++j) {
ret.results[i].data.array.shape[j] = Int_val(Field(ocaml_shape, j));
}
// Build the strides array
ocaml_strides = value_get_strides(h);
int strides_len = Wosize_val(ocaml_strides);
ret.results[i].data.array.strides_len = strides_len;
ret.results[i].data.array.strides =
(int*)malloc(strides_len * sizeof(int));
for (j = 0; j < strides_len; ++j) {
ret.results[i].data.array.strides[j] =
Int_val(Field(ocaml_strides, j));
}
}
}
}
CAMLreturnT(return_val_t, ret);
}
CAMLprim value unix_rmdir(value path)
{
if (rmdir(String_val(path)) == -1) uerror("rmdir", path);
return Val_unit;
}
CAMLprim value caml_sys_file_exists(value name)
{
struct stat st;
return Val_bool(stat(String_val(name), &st) == 0);
}
CAMLprim value caml_extunix_recvmsg(value fd_val)
{
CAMLparam1(fd_val);
CAMLlocal2(data, res);
struct msghdr msg;
int fd = Int_val(fd_val);
int recvfd;
ssize_t len;
struct iovec iov[1];
char buf[4096];
#if defined(CMSG_SPACE)
union {
struct cmsghdr cmsg; /* just for alignment */
char control[CMSG_SPACE(sizeof recvfd)];
} control_un;
struct cmsghdr *cmsgp;
memset(&msg, 0, sizeof msg);
msg.msg_control = control_un.control;
msg.msg_controllen = CMSG_LEN(sizeof recvfd);
#else
msg.msg_accrights = (caddr_t)&recvfd;
msg.msg_accrightslen = sizeof recvfd;
#endif
iov[0].iov_base = buf;
iov[0].iov_len = sizeof buf;
msg.msg_iov = iov;
msg.msg_iovlen = 1;
caml_enter_blocking_section();
len = recvmsg(fd, &msg, 0);
caml_leave_blocking_section();
if (len == -1)
uerror("recvmsg", Nothing);
res = caml_alloc(2, 0);
#if defined(CMSG_SPACE)
cmsgp = CMSG_FIRSTHDR(&msg);
if (cmsgp == NULL) {
Store_field(res, 0, Val_none);
} else {
CAMLlocal1(some_fd);
if (cmsgp->cmsg_len != CMSG_LEN(sizeof recvfd))
unix_error(EINVAL, "recvmsg", caml_copy_string("wrong descriptor size"));
if (cmsgp->cmsg_level != SOL_SOCKET || cmsgp->cmsg_type != SCM_RIGHTS)
unix_error(EINVAL, "recvmsg", caml_copy_string("invalid protocol"));
some_fd = caml_alloc(1, 0);
Store_field(some_fd, 0, Val_int(*(int *)CMSG_DATA(cmsgp)));
Store_field(res, 0, some_fd);
}
#else
if (msg.msg_accrightslen != sizeof recvfd) {
Store_field(res, 0, Val_none);
} else {
CAMLlocal1(some_fd);
some_fd = caml_alloc(1, 0);
Store_field(some_fd, 0, Val_int(recvfd));
Store_field(res, 0, some_fd);
}
#endif
data = caml_alloc_string(len);
memcpy(String_val(data), buf, len);
Store_field(res, 1, data);
CAMLreturn (res);
}
PREFIX value ml_elm_fileselector_path_set(value v_obj, value v_path)
{
elm_fileselector_path_set((Evas_Object*) v_obj, String_val(v_path));
return Val_unit;
}