void ns_unix_error(int errcode, char *cmdname, value cmdarg)
{
CAMLparam0();
CAMLlocal4(res,name,err,arg);
name = err = arg = Val_unit;
Begin_roots3 (name, err, arg);
arg = cmdarg == Nothing ? copy_string("") : cmdarg;
name = copy_string(cmdname);
err =
cst_to_constr(errcode, ns_error_table, sizeof(ns_error_table)/sizeof(int));
if (unix_error_exn == NULL) {
unix_error_exn = caml_named_value("Ocamllib.Unix_error");
if (unix_error_exn == NULL)
invalid_argument("Exception Ocamllib.Unix_error not initialized, please link Ocamllib.cma");
}
res = alloc_small(4, 0);
Field(res, 0) = *unix_error_exn;
Field(res, 1) = err;
Field(res, 2) = name;
Field(res, 3) = arg;
End_roots();
mlraise(res);
CAMLreturn0;
}
value makeblock3(value tag, value accu,value arg1, value arg2)
{
value res;
Begin_roots3(accu,arg1,arg2);
res = alloc(3, Int_val(tag));
End_roots();
initialize(&Field(res,0), accu);
initialize(&Field(res,1), arg1);
initialize(&Field(res,2), arg2);
return res;
}
static value alloc_group_entry(struct group *entry)
{
value res;
value name = Val_unit, pass = Val_unit, mem = Val_unit;
Begin_roots3 (name, pass, mem);
name = caml_copy_string(entry->gr_name);
pass = caml_copy_string(entry->gr_passwd);
mem = caml_copy_string_array((const char**)entry->gr_mem);
res = caml_alloc_4(0, name, pass,
Val_int(entry->gr_gid), mem);
End_roots();
return res;
}
/* Raises exceptions which take two arguments */
static void raise_with_two_args(value tag, value arg1, value arg2)
{
value v_exc;
/* Protects tag, arg1 and arg2 from being reclaimed by the garbage
collector when the exception value is allocated */
Begin_roots3(tag, arg1, arg2);
v_exc = caml_alloc_small(3, 0);
Field(v_exc, 0) = tag;
Field(v_exc, 1) = arg1;
Field(v_exc, 2) = arg2;
End_roots();
caml_raise(v_exc);
}
static value alloc_group_entry(struct group *entry)
{
value res;
value name = Val_unit, pass = Val_unit, mem = Val_unit;
Begin_roots3 (name, pass, mem);
name = copy_string(entry->gr_name);
pass = copy_string(entry->gr_passwd);
mem = copy_string_array((const char**)entry->gr_mem);
res = alloc_small(4, 0);
Init_field(res, 0, name);
Init_field(res, 1, pass);
Init_field(res, 2, Val_int(entry->gr_gid));
Init_field(res, 3, mem);
End_roots();
return res;
}
static value alloc_service_entry(struct servent *entry)
{
value res;
value name = Val_unit, aliases = Val_unit, proto = Val_unit;
Begin_roots3 (name, aliases, proto);
name = copy_string(entry->s_name);
aliases = copy_string_array((const char**)entry->s_aliases);
proto = copy_string(entry->s_proto);
res = alloc_small(4, 0);
Field(res,0) = name;
Field(res,1) = aliases;
Field(res,2) = Val_int(ntohs(entry->s_port));
Field(res,3) = proto;
End_roots();
return res;
}
static void camlzip_bzerror(char * fn, int err)
{
char * msg;
value s1 = Val_unit, s2 = Val_unit, bucket = Val_unit;
if (camlzip_bzerror_exn == NULL) {
camlzip_bzerror_exn = caml_named_value("Bzlib.Error");
if (camlzip_bzerror_exn == NULL)
invalid_argument("Exception Bzlib.Error not initialized");
}
Begin_roots3(s1, s2, bucket);
s1 = copy_string(fn);
switch (err) {
case BZ_CONFIG_ERROR:
s2 = Val_int(0);
break;
case BZ_SEQUENCE_ERROR:
s2 = Val_int(1);
break;
case BZ_PARAM_ERROR:
s2 = Val_int(2);
break;
case BZ_MEM_ERROR:
s2 = Val_int(3);
break;
case BZ_DATA_ERROR:
s2 = Val_int(4);
break;
case BZ_DATA_ERROR_MAGIC:
s2 = Val_int(5);
break;
default:
s2 = Val_int(6);
}
bucket = alloc_small(3, 0);
Field(bucket, 0) = *camlzip_bzerror_exn;
Field(bucket, 1) = s1;
Field(bucket, 2) = s2;
End_roots();
mlraise(bucket);
}
CAMLprim value unix_select_r(CAML_R, value readfds, value writefds, value exceptfds,
value timeout)
{
fd_set read, write, except;
int maxfd;
double tm;
struct timeval tv;
struct timeval * tvp;
int retcode;
value res;
Begin_roots3 (readfds, writefds, exceptfds);
maxfd = -1;
retcode = fdlist_to_fdset(readfds, &read, &maxfd);
retcode += fdlist_to_fdset(writefds, &write, &maxfd);
retcode += fdlist_to_fdset(exceptfds, &except, &maxfd);
/* PR#5563: if a bad fd was encountered, report EINVAL error */
if (retcode != 0) unix_error_r(ctx, EINVAL, "select", Nothing);
tm = Double_val(timeout);
if (tm < 0.0)
tvp = (struct timeval *) NULL;
else {
tv.tv_sec = (int) tm;
tv.tv_usec = (int) (1e6 * (tm - tv.tv_sec));
tvp = &tv;
}
caml_enter_blocking_section_r(ctx);
retcode = select(maxfd + 1, &read, &write, &except, tvp);
caml_leave_blocking_section_r(ctx);
if (retcode == -1) uerror_r(ctx,"select", Nothing);
readfds = fdset_to_fdlist_r(ctx, readfds, &read);
writefds = fdset_to_fdlist_r(ctx, writefds, &write);
exceptfds = fdset_to_fdlist_r(ctx, exceptfds, &except);
res = caml_alloc_small_r(ctx, 3, 0);
Field(res, 0) = readfds;
Field(res, 1) = writefds;
Field(res, 2) = exceptfds;
End_roots();
return res;
}
static void store_in_job(value job_v)
{
value adr = Val_unit;
value addr_list = Val_unit;
int i;
/* printf("store_in_job %d\n", job_naddresses); */
Begin_roots3 (job_v, addr_list, adr);
#ifdef h_addr
addr_list = alloc_small(job_naddresses, 0);
for(i=0; i<job_naddresses; i++){
adr = alloc_one_addr(ip_job_result + i * entry_h_length);
modify(&Field(addr_list,i), adr);
}
#else
adr = alloc_one_addr(ip_job_result);
addr_list = alloc_small(1, 0);
Field(addr_list, 0) = adr;
#endif /* h_addr */
modify(&Field(job_v,1), addr_list);
End_roots();
}
static void camlzip_error(char * fn, value vzs)
{
char * msg;
value s1 = Val_unit, s2 = Val_unit, bucket = Val_unit;
msg = ZStream_val(vzs)->msg;
if (msg == NULL) msg = "";
if (camlzip_error_exn == NULL) {
camlzip_error_exn = caml_named_value("Zlib.Error");
if (camlzip_error_exn == NULL)
caml_invalid_argument("Exception Zlib.Error not initialized");
}
Begin_roots3(s1, s2, bucket);
s1 = caml_copy_string(fn);
s2 = caml_copy_string(msg);
bucket = caml_alloc_small(3, 0);
Field(bucket, 0) = *camlzip_error_exn;
Field(bucket, 1) = s1;
Field(bucket, 2) = s2;
End_roots();
caml_raise(bucket);
}
CAMLprim value unix_select(value readfds, value writefds, value exceptfds,
value timeout)
{
fd_set read, write, except;
int maxfd;
double tm;
struct timeval tv;
struct timeval * tvp;
int retcode;
value res;
Begin_roots3 (readfds, writefds, exceptfds);
maxfd = -1;
fdlist_to_fdset(readfds, &read, &maxfd);
fdlist_to_fdset(writefds, &write, &maxfd);
fdlist_to_fdset(exceptfds, &except, &maxfd);
tm = Double_val(timeout);
if (tm < 0.0)
tvp = (struct timeval *) NULL;
else {
tv.tv_sec = (int) tm;
tv.tv_usec = (int) (1e6 * (tm - tv.tv_sec));
tvp = &tv;
}
enter_blocking_section();
retcode = select(maxfd + 1, &read, &write, &except, tvp);
leave_blocking_section();
if (retcode == -1) uerror("select", Nothing);
readfds = fdset_to_fdlist(readfds, &read);
writefds = fdset_to_fdlist(writefds, &write);
exceptfds = fdset_to_fdlist(exceptfds, &except);
res = alloc_small(3, 0);
Field(res, 0) = readfds;
Field(res, 1) = writefds;
Field(res, 2) = exceptfds;
End_roots();
return res;
}
void unix_error(int errcode, char *cmdname, value cmdarg)
{
value res;
value name = Val_unit, err = Val_unit, arg = Val_unit;
int errconstr;
Begin_roots3 (name, err, arg);
arg = cmdarg == Nothing ? copy_string("") : cmdarg;
name = copy_string(cmdname);
err = unix_error_of_code (errcode);
if (unix_error_exn == NULL) {
unix_error_exn = caml_named_value("Unix.Unix_error");
if (unix_error_exn == NULL)
invalid_argument("Exception Unix.Unix_error not initialized, please link unix.cma");
}
res = alloc_small(4, 0);
Field(res, 0) = *unix_error_exn;
Field(res, 1) = err;
Field(res, 2) = name;
Field(res, 3) = arg;
End_roots();
mlraise(res);
}
/* 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
uwt_udp_recv_own_cb(uv_udp_t* handle,
ssize_t nread,
const uv_buf_t* buf,
const struct sockaddr* addr,
unsigned int flags)
{
HANDLE_CB_INIT_WITH_CLEAN(uh, handle);
value exn = Val_unit;
#ifndef UWT_NO_COPY_READ
bool buf_not_cleaned = true;
const int read_ba = uh->use_read_ba;
#else
(void) buf;
#endif
if ( uh->close_called == 0 && (nread != 0 || addr != NULL) ){
/* nread == 0 && addr == NULL only means we need to clear
the buffer */
assert ( uh->cb_read != CB_INVALID );
value param;
if ( nread < 0 ){
param = caml_alloc_small(1,Error_tag);
Field(param,0) = Val_uwt_error(nread);
}
else {
value triple = Val_unit;
value sockaddr = Val_unit;
param = Val_unit;
Begin_roots3(triple,sockaddr,param);
value is_partial;
if ( addr != NULL ){
param = uwt__alloc_sockaddr(addr);
if ( param != Val_unit ){
sockaddr = caml_alloc_small(1,Some_tag);
Field(sockaddr,0) = param;
}
}
if ( flags & UV_UDP_PARTIAL ){
is_partial = Val_long(1);
}
else {
is_partial = Val_long(0);
}
#ifndef UWT_NO_COPY_READ
if ( nread != 0 && read_ba == 0 ){
value o = Field(GET_CB_VAL(uh->cb_read),0);
memcpy(String_val(o) + uh->x.obuf_offset, buf->base, nread);
}
#endif
triple = caml_alloc_small(3,0);
Field(triple,0) = Val_long(nread);
Field(triple,1) = is_partial;
Field(triple,2) = sockaddr;
param = caml_alloc_small(1,Ok_tag);
Field(param,0) = triple;
End_roots();
}
#ifndef UWT_NO_COPY_READ
if ( buf->base && read_ba == 0 ){
buf_not_cleaned = false;
uwt__free_uv_buf_t_const(buf);
}
#endif
uh->can_reuse_cb_read = 1;
uh->read_waiting = 0;
uh->in_use_cnt--;
exn = Field(GET_CB_VAL(uh->cb_read),1);
uwt__gr_unregister(&uh->cb_read);
exn = caml_callback2_exn(*uwt__global_wakeup,exn,param);
if ( uh->close_called == 0 && uh->can_reuse_cb_read == 1 ){
uv_udp_recv_stop(handle);
uh->can_reuse_cb_read = 0;
}
}
#ifndef UWT_NO_COPY_READ
if ( read_ba == 0 && buf_not_cleaned && buf->base ){
uwt__free_uv_buf_t_const(buf);
}
#endif
HANDLE_CB_RET(exn);
}
