CAMLprim value caml_condition_wait(value cond, value mut)
{
int retcode;
HANDLE m = Mutex_val(mut);
HANDLE s = Condition_val(cond)->sem;
HANDLE handles[2];
Condition_val(cond)->count ++;
Begin_roots2(cond, mut) /* prevent deallocation of cond and mutex */
enter_blocking_section();
/* Release mutex */
ReleaseMutex(m);
/* Wait for semaphore to be non-null, and decrement it.
Simultaneously, re-acquire mutex. */
handles[0] = s;
handles[1] = m;
retcode = WaitForMultipleObjects(2, handles, TRUE, INFINITE);
leave_blocking_section();
End_roots();
if (retcode == WAIT_FAILED) caml_wthread_error("Condition.wait");
return Val_unit;
}
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)
invalid_argument("Exception Zlib.Error not initialized");
}
Begin_roots3(s1, s2, bucket);
s1 = copy_string(fn);
s2 = copy_string(msg);
bucket = alloc_small(3, 0);
Field(bucket, 0) = *camlzip_error_exn;
Field(bucket, 1) = s1;
Field(bucket, 2) = s2;
End_roots();
mlraise(bucket);
}
CAMLprim value unix_pipe(value unit)
{
SECURITY_ATTRIBUTES attr;
HANDLE readh, writeh;
value readfd = Val_unit, writefd = Val_unit, res;
attr.nLength = sizeof(attr);
attr.lpSecurityDescriptor = NULL;
attr.bInheritHandle = TRUE;
if (! CreatePipe(&readh, &writeh, &attr, SIZEBUF)) {
win32_maperr(GetLastError());
uerror("pipe", Nothing);
}
Begin_roots2(readfd, writefd)
readfd = win_alloc_handle(readh);
writefd = win_alloc_handle(writeh);
res = alloc_small(2, 0);
Field(res, 0) = readfd;
Field(res, 1) = writefd;
End_roots();
return res;
}
value caml_gr_dump_image(value image)
{
int width, height, i, j;
XImage * idata, * imask;
value m = Val_unit;
Begin_roots2(image, m);
caml_gr_check_open();
width = Width_im(image);
height = Height_im(image);
m = alloc(height, 0);
for (i = 0; i < height; i++) {
value v = alloc(width, 0);
modify(&Field(m, i), v);
}
idata =
XGetImage(caml_gr_display, Data_im(image), 0, 0, width, height, (-1),
ZPixmap);
for (i = 0; i < height; i++)
for (j = 0; j < width; j++)
Field(Field(m, i), j) =
Val_int(caml_gr_rgb_pixel(XGetPixel(idata, j, i)));
XDestroyImage(idata);
if (Mask_im(image) != None) {
imask =
XGetImage(caml_gr_display, Mask_im(image), 0, 0, width, height, 1,
ZPixmap);
for (i = 0; i < height; i++)
for (j = 0; j < width; j++)
if (XGetPixel(imask, j, i) == 0)
Field(Field(m, i), j) = Val_int(Transparent);
XDestroyImage(imask);
}
End_roots();
return m;
}
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;
}
CAMLprim value unix_single_write(value fd, value buf, value vofs, value vlen)
{
intnat ofs, len, written;
DWORD numbytes, numwritten;
char iobuf[UNIX_BUFFER_SIZE];
DWORD err = 0;
Begin_root (buf);
ofs = Long_val(vofs);
len = Long_val(vlen);
written = 0;
if (len > 0) {
numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len;
memmove (iobuf, &Byte(buf, ofs), numbytes);
if (Descr_kind_val(fd) == KIND_SOCKET) {
int ret;
SOCKET s = Socket_val(fd);
enter_blocking_section();
ret = send(s, iobuf, numbytes, 0);
if (ret == SOCKET_ERROR) err = WSAGetLastError();
leave_blocking_section();
numwritten = ret;
} else {
HANDLE h = Handle_val(fd);
enter_blocking_section();
if (! WriteFile(h, iobuf, numbytes, &numwritten, NULL))
err = GetLastError();
leave_blocking_section();
}
if (err) {
win32_maperr(err);
uerror("single_write", Nothing);
}
written = numwritten;
}
End_roots();
return Val_long(written);
}
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);
}
static value alloc_process_status(int pid, int status)
{
value st, res;
if (WIFEXITED(status)) {
st = alloc_small(1, TAG_WEXITED);
Field(st, 0) = Val_int(WEXITSTATUS(status));
}
else if (WIFSTOPPED(status)) {
st = alloc_small(1, TAG_WSTOPPED);
Field(st, 0) = Val_int(caml_rev_convert_signal_number(WSTOPSIG(status)));
}
else {
st = alloc_small(1, TAG_WSIGNALED);
Field(st, 0) = Val_int(caml_rev_convert_signal_number(WTERMSIG(status)));
}
Begin_root (st);
res = alloc_small(2, 0);
Field(res, 0) = Val_int(pid);
Field(res, 1) = st;
End_roots();
return res;
}
CAMLprim value unix_recv(value sock, value buff, value ofs, value len, value flags)
{
SOCKET s = Socket_val(sock);
int flg = convert_flag_list(flags, msg_flag_table);
int ret;
intnat numbytes;
char iobuf[UNIX_BUFFER_SIZE];
DWORD err = 0;
Begin_root (buff);
numbytes = Long_val(len);
if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
enter_blocking_section();
ret = recv(s, iobuf, (int) numbytes, flg);
if (ret == -1) err = WSAGetLastError();
leave_blocking_section();
if (ret == -1) {
win32_maperr(err);
uerror("recv", Nothing);
}
memmove (&Byte(buff, Long_val(ofs)), iobuf, ret);
End_roots();
return Val_int(ret);
}
static void caml_zlib_error(char * fn, value vzs)
{
char * msg;
value s1 = Val_unit, s2 = Val_unit, tuple = Val_unit, bucket = Val_unit;
msg = ZStream_val(vzs)->msg;
if (msg == NULL) msg = "";
if (caml_zlib_error_exn == NULL) {
caml_zlib_error_exn = caml_named_value("Cryptokit.Error");
if (caml_zlib_error_exn == NULL)
invalid_argument("Exception Cryptokit.Error not initialized");
}
Begin_roots4(s1, s2, tuple, bucket);
s1 = copy_string(fn);
s2 = copy_string(msg);
tuple = alloc_small(2, 0);
Field(tuple, 0) = s1;
Field(tuple, 1) = s2;
bucket = alloc_small(2, 0);
Field(bucket, 0) = *caml_zlib_error_exn;
Field(bucket, 1) = tuple;
End_roots();
mlraise(bucket);
}
/* Initialisation, based on tkMain.c */
value camltk_opentk(value argv) /* ML */
{
/* argv must contain argv[0], the application command name */
value tmp = Val_unit;
char *argv0;
Begin_root(tmp);
if ( argv == Val_int(0) ){
failwith("camltk_opentk: argv is empty");
}
argv0 = String_val( Field( argv, 0 ) );
if (!cltk_slave_mode) {
/* Create an interpreter, dies if error */
#if TCL_MAJOR_VERSION >= 8
Tcl_FindExecutable(String_val(argv0));
#endif
cltclinterp = Tcl_CreateInterp();
if (Tcl_Init(cltclinterp) != TCL_OK)
tk_error(cltclinterp->result);
Tcl_SetVar(cltclinterp, "argv0", String_val (argv0), TCL_GLOBAL_ONLY);
{ /* Sets argv if needed */
int argc = 0;
tmp = Field(argv, 1); /* starts from argv[1] */
while ( tmp != Val_int(0) ) {
argc++;
tmp = Field(tmp, 1);
}
if( argc != 0 ){
int i;
char *args;
char **tkargv;
char argcstr[256];
tkargv = malloc( sizeof( char* ) * argc );
tmp = Field(argv, 1); /* starts from argv[1] */
i = 0;
while ( tmp != Val_int(0) ) {
tkargv[i] = String_val(Field(tmp, 0));
tmp = Field(tmp, 1);
i++;
}
sprintf( argcstr, "%d", argc );
Tcl_SetVar(cltclinterp, "argc", argcstr, TCL_GLOBAL_ONLY);
args = Tcl_Merge(argc, tkargv); /* args must be freed by Tcl_Free */
Tcl_SetVar(cltclinterp, "argv", args, TCL_GLOBAL_ONLY);
Tcl_Free(args);
free( tkargv );
}
}
if (Tk_Init(cltclinterp) != TCL_OK)
tk_error(cltclinterp->result);
/* Retrieve the main window */
cltk_mainWindow = Tk_MainWindow(cltclinterp);
if (NULL == cltk_mainWindow)
tk_error(cltclinterp->result);
Tk_GeometryRequest(cltk_mainWindow,200,200);
}
/* Create the camlcallback command */
Tcl_CreateCommand(cltclinterp,
CAMLCB, CamlCBCmd,
(ClientData)NULL,(Tcl_CmdDeleteProc *)NULL);
/* This is required by "unknown" and thus autoload */
Tcl_SetVar(cltclinterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
/* Our hack for implementing break in callbacks */
Tcl_SetVar(cltclinterp, "BreakBindingsSequence", "0", TCL_GLOBAL_ONLY);
/* Load the traditional rc file */
{
char *home = getenv("HOME");
if (home != NULL) {
char *f = stat_alloc(strlen(home)+strlen(RCNAME)+2);
f[0]='\0';
strcat(f, home);
strcat(f, "/");
strcat(f, RCNAME);
if (0 == access(f,R_OK))
if (TCL_OK != Tcl_EvalFile(cltclinterp,f)) {
stat_free(f);
tk_error(cltclinterp->result);
};
stat_free(f);
}
}
End_roots();
return Val_unit;
}
CAMLprim value mlresolv_query(value vdname, value vclass, value vtype)
{
union {
HEADER hdr; /* defined in resolv.h */
u_char buf[PACKETSZ]; /* defined in arpa/nameser.h */
} response;
int rc;
u_char *cp, *tcp;
u_char *eom;
char r_name[MAXDNAME+1];
u_short r_class;
u_short r_type;
u_int32_t r_ttl;
u_short r_len;
int ancount, qdcount;
value vres = Val_emptylist;
if(vtype == caml_hash_variant("PTR")) {
int a, b, c, d;
a = b = c = d = 0;
sscanf(String_val(vdname), "%u.%u.%u.%u", &a, &b, &c, &d);
sprintf(r_name, "%u.%u.%u.%u.in-addr.arpa", d, c, b, a);
rc = res_query(r_name,
mlvariant_to_c(rr_class, vclass),
mlvariant_to_c(rr_type, vtype),
(u_char*)&response, sizeof(response));
} else
rc = res_query(String_val(vdname),
mlvariant_to_c(rr_class, vclass),
mlvariant_to_c(rr_type, vtype),
(u_char*)&response, sizeof(response));
if (rc < 0) {
switch (h_errno) {
case NETDB_INTERNAL:
mlresolv_error(errno);
case HOST_NOT_FOUND: /* Authoritative Answer Host not found */
raise_constant(*mlresolv_host_not_found_exn);
case TRY_AGAIN: /* Non-Authoritative Host not found, or SERVERFAIL */
raise_constant(*mlresolv_try_again_exn);
case NO_RECOVERY:
raise_constant(*mlresolv_no_recovery_exn);
case NO_DATA: /* Valid name, no data record of requested type */
raise_constant(*mlresolv_no_data_exn);
case NETDB_SUCCESS: /* no problem */
defaykt:
failwith("res_query: unknown error");
}
}
cp = (u_char *)&response.buf + sizeof(HEADER);
eom = (u_char *)&response.buf + rc;
ancount = ntohs(response.hdr.ancount) + ntohs(response.hdr.nscount);
qdcount = ntohs(response.hdr.qdcount);
for (; (qdcount > 0) && (cp < eom); qdcount--) {
rc = dn_skipname(cp, eom) + QFIXEDSZ;
if(rc < 0)
failwith("dn_skipname failed");
cp += rc;
}
for (; (ancount > 0) && (cp < eom); ancount--) {
value vrdata, vfields = Val_unit;
rc = dn_expand(response.buf, eom, cp, (void*)r_name, MAXDNAME);
if(rc < 0)
failwith("dn_expand1 failed");
cp += rc;
NS_GET16(r_type, cp);
NS_GET16(r_class, cp);
NS_GET32(r_ttl, cp);
NS_GET16(r_len, cp);
if(cp + r_len > eom) /* is this check necessary? */
r_len = eom - cp;
tcp = cp;
switch(r_type) {
case ns_t_a:
/* if(r_class == ns_c_in || r_class == ns_c_hs) { */
if(INADDRSZ > r_len)
vfields = copy_string("");
else {
struct in_addr inaddr;
char *address;
bcopy(tcp, (char *)&inaddr, INADDRSZ);
address = (char *)inet_ntoa(inaddr);
vfields = copy_string(address);
}
break;
case ns_t_cname:
case ns_t_ns:
case ns_t_mb:
case ns_t_md:
case ns_t_mf:
case ns_t_mg:
case ns_t_mr:
case ns_t_ptr:
case ns_t_nsap_ptr:
{
char r_name[MAXDNAME+1];
rc = dn_expand(response.buf, eom, cp, (void *) r_name, MAXDNAME);
if(rc < 0)
vfields = copy_string("");
else
vfields = copy_string(r_name);
break;
}
case ns_t_null: /* max up to 65535 */
vfields = caml_alloc_string(r_len);
memmove(String_val(vfields), cp, r_len);
break;
case ns_t_txt: {
int txtlen, rdata_len = r_len;
value newcons, txt;
vfields = Val_emptylist;
while(tcp < eom && *tcp <= rdata_len) {
txtlen = *tcp++;
txt = caml_alloc_string(txtlen);
memmove(String_val(txt), tcp, txtlen);
tcp += txtlen;
rdata_len -= txtlen+1;
newcons = alloc_small(2, 0);
Field(newcons, 0) = txt;
Field(newcons, 1) = vfields;
vfields = newcons;
}
break;
}
case ns_t_srv:
if(INT16SZ * 3 <= r_len) {
char r_name[MAXDNAME+1];
int prio, weight, port;
NS_GET16(prio, tcp);
NS_GET16(weight, tcp);
NS_GET16(port, tcp);
rc = dn_expand(response.buf, eom, tcp, (void *) r_name, MAXDNAME);
vfields = alloc_small(4, 0);
Field(vfields, 0) = Val_int(prio);
Field(vfields, 1) = Val_int(weight);
Field(vfields, 2) = Val_int(port);
if(rc < 0)
Field(vfields, 3) = copy_string("");
else
Field(vfields, 3) = copy_string(r_name);
}
break;
case ns_t_mx:
case ns_t_rt:
case ns_t_afsdb:
if(INT16SZ <= r_len) {
char r_name[MAXDNAME+1];
int prio;
NS_GET16(prio, tcp);
rc = dn_expand(response.buf, eom, tcp, (void *) r_name, MAXDNAME);
vfields = alloc_small(2, 0);
Field(vfields, 0) = Val_int(prio);
if(rc < 0)
Field(vfields, 1) = copy_string("");
else
Field(vfields, 1) = copy_string(r_name);
}
break;
case ns_t_soa:
{
char mname[MAXDNAME+1];
char rname[MAXDNAME+1];
u_int serial, minimum;
int refresh, retry, expire;
if((rc = dn_expand(response.buf, eom, tcp, (void *)mname, MAXDNAME)) < 0)
break;
tcp += rc;
if((rc = dn_expand(response.buf, eom, tcp, (void *)rname, MAXDNAME)) < 0)
break;
tcp += rc;
if (tcp - cp + INT32SZ * 5 > r_len)
break;
NS_GET32(serial, tcp);
NS_GET32(refresh, tcp);
NS_GET32(retry, tcp);
NS_GET32(expire, tcp);
NS_GET32(minimum, tcp);
vfields = alloc_small(7, 0);
Field(vfields, 0) = copy_string(mname);
Field(vfields, 1) = copy_string(rname);
Field(vfields, 2) = Val_int(serial);
Field(vfields, 3) = Val_int(refresh);
Field(vfields, 4) = Val_int(retry);
Field(vfields, 5) = Val_int(expire);
Field(vfields, 6) = Val_int(minimum);
}
break;
case ns_t_minfo:
{
char rmailbx[MAXDNAME+1];
char emailbx[MAXDNAME+1];
if((rc = dn_expand(response.buf, eom, tcp, rmailbx, MAXDNAME)) < 0)
break;
tcp += rc;
if((rc = dn_expand(response.buf, eom, tcp, emailbx, MAXDNAME)) < 0)
break;
vfields = alloc_small(2, 0);
Field(vfields, 0) = copy_string(rmailbx);
Field(vfields, 1) = copy_string(emailbx);
}
break;
/* two strings */
case ns_t_hinfo:
case ns_t_isdn: /* <ISDN-address> <sa> */
case ns_t_nsap:
if(r_len > 0 && *tcp < r_len) {
value str1;
value str2;
rc = *tcp++;
if(r_type == ns_t_nsap) {
int result = 0;
for(; rc; rc--, tcp++)
result += result * 10 + (*tcp - 0x38);
str1 = Val_int(result);
}
else {
str1 = caml_alloc_string(rc);
memmove(String_val(str1), tcp, rc);
tcp += rc;
}
if(rc + 1 > r_len && *tcp + rc + 2 >= r_len) {
rc = *tcp++;
str2 = caml_alloc_string(rc);
memmove(String_val(str2), tcp, rc);
}
else
str2 = copy_string("");
vfields = caml_alloc_small(2, 0);
Field(vfields, 0) = str1;
Field(vfields, 1) = str2;
}
break;
case ns_t_wks:
if(INADDRSZ + 1 <= r_len) {
struct in_addr inaddr;
char* address;
u_short protocol;
value bitmap;
bcopy(tcp, (char *) &inaddr, INADDRSZ);
address = (char*) inet_ntoa(inaddr);
tcp += INADDRSZ;
protocol = *tcp++; /* getprotobynumber(*cp) */
/*
n = 0;
while (cp < eom) {
c = *cp++;
do {
if (c & 0200) {
int port;
port = htons((u_short)n);
if (protocol != NULL)
service = getservbyport(port, protocol->p_name);
else
service = NULL;
if (service != NULL)
doprintf((" %s", service->s_name));
else
doprintf((" %s", dtoa(n)));
}
c <<= 1;
} while (++n & 07);
}
doprintf((" )"));
*/
bitmap = caml_alloc_string(r_len - INADDRSZ - 1);
memmove(String_val(bitmap), tcp, eom - tcp);
vfields = alloc_small(4, 0);
Field(vfields, 0) = copy_string(address);
Field(vfields, 1) = Val_int(protocol);
Field(vfields, 2) = bitmap;
}
break;
case ns_t_rp: /* <mbox-dname> <txt-dname> */
{
char rname1[MAXDNAME+1];
char rname2[MAXDNAME+1];
rc = dn_expand(response.buf, eom, tcp, rname1, MAXDNAME);
if(rc < 0)
break;
tcp += rc;
rc = dn_expand(response.buf, eom, tcp, rname2, MAXDNAME);
if(rc < 0)
break;
vfields = alloc_small(2, 0);
Field(vfields, 0) = copy_string(rname1);
Field(vfields, 1) = copy_string(rname2);
}
break;
case ns_t_x25: /* <PSDN-address> */
if(r_len > 0 && *tcp >= r_len) {
rc = *tcp++;
vfields = caml_alloc_string(rc);
memmove(String_val(vfields), tcp, rc);
}
else
vfields = copy_string("");
break;
case ns_t_px:
if(r_len > INT16SZ) {
int pref;
char rname1[MAXDNAME];
char rname2[MAXDNAME];
NS_GET16(pref, tcp);
rc = dn_expand(response.buf, eom, tcp, rname1, MAXDNAME);
if(rc < 0)
break;
tcp += rc;
rc = dn_expand(response.buf, eom, tcp, rname2, MAXDNAME);
if(rc < 0)
break;
tcp += rc;
vfields = alloc_small(2, 0);
Field(vfields, 0) = copy_string(rname1);
Field(vfields, 1) = copy_string(rname2);
}
break;
case ns_t_gpos:
if(r_len > 0 && *tcp <= r_len) {
float f1, f2, f3;
char *tmp;
rc = *tcp++;
tmp = (char *) malloc(rc + 1);
bcopy(tcp, tmp, rc);
tmp[rc] = '\0';
f1 = atof(tmp);
tcp += rc;
if(tcp < eom && tcp + *tcp <= eom) {
if(*tcp > rc)
tmp = realloc(tmp, *tcp);
rc = *tcp++;
bcopy(tcp, tmp, rc);
tmp[rc] = '\0';
f2 = atof(tmp);
tcp += rc;
}
else
f2 = 0.0;
if(tcp < eom && tcp + *tcp <= eom) {
if(*tcp > rc)
tmp = realloc(tmp, *tcp);
rc = *tcp++;
bcopy(tcp, tmp, rc);
tmp[rc] = '\0';
f3 = atof(tmp);
tcp += rc;
}
else
f3 = 0.0;
free(tmp);
vfields = alloc_small(3, 0);
Field(vfields, 0) = copy_double((double)f1);
Field(vfields, 1) = copy_double((double)f2);
Field(vfields, 2) = copy_double((double)f3);
}
break;
case ns_t_loc:
failwith("LOC not implemented");
/*
if(r_len > 0 && *tcp != 0)
failwith("Invalid version in LOC RDATA");
if(r_len > 0) {
rc = INT
n = INT32SZ + 3*INT32SZ;
if (check_size(rname, type, cp, msg, eor, n) < 0)
break;
c = _getlong(cp);
cp += INT32SZ;
n = _getlong(cp);
doprintf(("\t%s ", pr_spherical(n, "N", "S")));
cp += INT32SZ;
n = _getlong(cp);
doprintf((" %s ", pr_spherical(n, "E", "W")));
cp += INT32SZ;
n = _getlong(cp);
doprintf((" %sm ", pr_vertical(n, "", "-")));
cp += INT32SZ;
doprintf((" %sm", pr_precision((c >> 16) & 0xff)));
doprintf((" %sm", pr_precision((c >> 8) & 0xff)));
doprintf((" %sm", pr_precision((c >> 0) & 0xff)));
break;
*/
/*
case T_UID:
case T_GID:
if(INT32SZ <= r_len)
NS_GET32(rc, cp);
if (dlen == INT32SZ) {
n = _getlong(cp);
doprintf(("\t%s", dtoa(n)));
cp += INT32SZ;
}
break;
case T_UINFO:
doprintf(("\t\"%s\"", stoa(cp, dlen, TRUE)));
cp += dlen;
break;
case T_UNSPEC:
cp += dlen;
break;
case T_AAAA:
if (dlen == IPNGSIZE) {
doprintf(("\t%s", ipng_ntoa(cp)));
cp += IPNGSIZE;
}
break;
case T_SIG:
if (check_size(rname, type, cp, msg, eor, INT16SZ) < 0)
break;
n = _getshort(cp);
if (n >= T_FIRST && n <= T_LAST)
doprintf(("\t%s", pr_type(n)));
else
doprintf(("\t%s", dtoa(n)));
cp += INT16SZ;
if (check_size(rname, type, cp, msg, eor, 1) < 0)
break;
n = *cp++;
doprintf((" %s", dtoa(n)));
if (check_size(rname, type, cp, msg, eor, 1) < 0)
break;
n = *cp++;
doprintf((" %s", dtoa(n)));
n = 3*INT32SZ + INT16SZ;
if (check_size(rname, type, cp, msg, eor, n) < 0)
break;
doprintf((" ("));
n = _getlong(cp);
doprintf(("\n\t\t\t%s", dtoa(n)));
doprintf(("\t\t;original ttl"));
cp += INT32SZ;
n = _getlong(cp);
doprintf(("\n\t\t\t%s", pr_date(n)));
doprintf(("\t;signature expiration"));
cp += INT32SZ;
n = _getlong(cp);
doprintf(("\n\t\t\t%s", pr_date(n)));
doprintf(("\t;signature inception"));
cp += INT32SZ;
n = _getshort(cp);
doprintf(("\n\t\t\t%s", dtoa(n)));
doprintf(("\t\t;key tag"));
cp += INT16SZ;
n = expand_name(rname, type, cp, msg, eom, dname);
if (n < 0)
break;
doprintf(("\n\t\t\t%s", pr_name(dname)));
cp += n;
if (cp < eor) {
register char *buf;
register int size;
n = eor - cp;
buf = base_ntoa(cp, n);
size = strlength(buf);
cp += n;
while ((n = (size > 64) ? 64 : size) > 0) {
doprintf(("\n\t%s", stoa((u_char *)buf, n, FALSE)));
buf += n; size -= n;
}
}
doprintf(("\n\t\t\t)"));
break;
case T_KEY:
if (check_size(rname, type, cp, msg, eor, INT16SZ) < 0)
break;
n = _getshort(cp);
doprintf(("\t0x%s", xtoa(n)));
cp += INT16SZ;
if (check_size(rname, type, cp, msg, eor, 1) < 0)
break;
n = *cp++;
doprintf((" %s", dtoa(n)));
if (check_size(rname, type, cp, msg, eor, 1) < 0)
break;
n = *cp++;
doprintf((" %s", dtoa(n)));
if (cp < eor) {
register char *buf;
register int size;
n = eor - cp;
buf = base_ntoa(cp, n);
size = strlength(buf);
cp += n;
doprintf((" ("));
while ((n = (size > 64) ? 64 : size) > 0) {
doprintf(("\n\t%s", stoa((u_char *)buf, n, FALSE)));
buf += n; size -= n;
}
doprintf(("\n\t\t\t)"));
}
break;
case T_NXT:
n = expand_name(rname, type, cp, msg, eom, dname);
if (n < 0)
break;
doprintf(("\t%s", pr_name(dname)));
cp += n;
n = 0;
while (cp < eor) {
c = *cp++;
do {
if (c & 0200) {
if (n >= T_FIRST && n <= T_LAST)
doprintf((" %s", pr_type(n)));
else
doprintf((" %s", dtoa(n)));
}
c <<= 1;
} while (++n & 07);
}
break;
case T_NAPTR:
if (check_size(rname, type, cp, msg, eor, INT16SZ) < 0)
break;
n = _getshort(cp);
doprintf(("\t%s", dtoa(n)));
cp += INT16SZ;
if (check_size(rname, type, cp, msg, eor, INT16SZ) < 0)
break;
n = _getshort(cp);
doprintf((" %s", dtoa(n)));
cp += INT16SZ;
if (check_size(rname, type, cp, msg, eor, 1) < 0)
break;
n = *cp++;
doprintf((" \"%s\"", stoa(cp, n, TRUE)));
cp += n;
if (check_size(rname, type, cp, msg, eor, 1) < 0)
break;
n = *cp++;
doprintf((" \"%s\"", stoa(cp, n, TRUE)));
cp += n;
if (check_size(rname, type, cp, msg, eor, 1) < 0)
break;
n = *cp++;
doprintf((" \"%s\"", stoa(cp, n, TRUE)));
cp += n;
n = expand_name(rname, type, cp, msg, eom, dname);
if (n < 0)
break;
doprintf((" %s", pr_name(dname)));
cp += n;
break;
case T_KX:
if (check_size(rname, type, cp, msg, eor, INT16SZ) < 0)
break;
n = _getshort(cp);
doprintf(("\t%s", dtoa(n)));
cp += INT16SZ;
n = expand_name(rname, type, cp, msg, eom, dname);
if (n < 0)
break;
doprintf((" %s", pr_name(dname)));
cp += n;
break;
case T_CERT:
if (check_size(rname, type, cp, msg, eor, INT16SZ) < 0)
break;
n = _getshort(cp);
doprintf(("\t%s", dtoa(n)));
cp += INT16SZ;
if (check_size(rname, type, cp, msg, eor, INT16SZ) < 0)
break;
n = _getshort(cp);
doprintf((" %s", dtoa(n)));
cp += INT16SZ;
if (check_size(rname, type, cp, msg, eor, 1) < 0)
break;
n = *cp++;
doprintf((" %s", dtoa(n)));
if (cp < eor) {
register char *buf;
register int size;
n = eor - cp;
buf = base_ntoa(cp, n);
size = strlength(buf);
cp += n;
doprintf((" ("));
while ((n = (size > 64) ? 64 : size) > 0) {
doprintf(("\n\t%s", stoa((u_char *)buf, n, FALSE)));
buf += n; size -= n;
}
doprintf(("\n\t\t\t)"));
}
break;
case T_EID:
failwith("EID not implemented");
break;
case T_NIMLOC:
failwith("NIMLOC not implemented");
break;
case T_ATMA:
failwith("ATMA not implemented");
*/
default:
failwith("unknown RDATA type");
}
if(vfields != Val_unit) {
value vrecord, vrdata, newcons;
Begin_root(vres);
vrecord = alloc_small(5, 0);
Field(vrecord, 0) = copy_string(r_name);
Field(vrecord, 1) = c_to_mlvariant(rr_type, r_type);
Field(vrecord, 2) = c_to_mlvariant(rr_class, r_class);
Field(vrecord, 3) = Val_int(r_ttl);
vrdata = alloc_small(2, 0);
Field(vrdata, 0) = c_to_mlvariant(rr_type, r_type);
Field(vrdata, 1) = vfields;
Field(vrecord, 4) = vrdata;
newcons = alloc_small(2, 0);
Field(newcons, 0) = vrecord;
Field(newcons, 1) = vres;
vres = newcons;
End_roots();
vrdata = Val_unit;
}
cp += r_len;
}
return vres;
}
CAMLprim value pcre_exec_stub0(
intnat v_opt, value v_rex, intnat v_pos, intnat v_subj_start, value v_subj,
value v_ovec, value v_maybe_cof, value v_workspace)
{
int ret;
int is_dfa = v_workspace != (value) NULL;
long
pos = v_pos,
len = caml_string_length(v_subj),
subj_start = v_subj_start;
long ovec_len = Wosize_val(v_ovec);
if (pos > len || pos < subj_start)
caml_invalid_argument("Pcre.pcre_exec_stub: illegal position");
if (subj_start > len || subj_start < 0)
caml_invalid_argument("Pcre.pcre_exec_stub: illegal subject start");
pos -= subj_start;
len -= subj_start;
{
const pcre *code = get_rex(v_rex); /* Compiled pattern */
const pcre_extra *extra = get_extra(v_rex); /* Extra info */
const char *ocaml_subj =
String_val(v_subj) + subj_start; /* Subject string */
const int opt = v_opt; /* Runtime options */
/* Special case when no callout functions specified */
if (v_maybe_cof == None) {
int *ovec = (int *) &Field(v_ovec, 0);
/* Performs the match */
if (is_dfa)
ret =
pcre_dfa_exec(code, extra, ocaml_subj, len, pos, opt, ovec, ovec_len,
(int *) &Field(v_workspace, 0), Wosize_val(v_workspace));
else
ret = pcre_exec(code, extra, ocaml_subj, len, pos, opt, ovec, ovec_len);
if (ret < 0) handle_exec_error("pcre_exec_stub", ret);
else handle_pcre_exec_result(ovec, v_ovec, ovec_len, subj_start, ret);
}
/* 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) * ovec_len);
int workspace_len;
int *workspace;
struct cod cod = { 0, (value *) NULL, (value *) NULL, (value) NULL };
struct pcre_extra new_extra =
#ifdef PCRE_EXTRA_MATCH_LIMIT_RECURSION
# ifdef PCRE_EXTRA_MARK
# ifdef PCRE_EXTRA_EXECUTABLE_JIT
{ PCRE_EXTRA_CALLOUT_DATA, NULL, 0, NULL, NULL, 0, NULL, NULL };
# else
{ PCRE_EXTRA_CALLOUT_DATA, NULL, 0, NULL, NULL, 0, NULL };
# endif
# else
{ PCRE_EXTRA_CALLOUT_DATA, NULL, 0, NULL, NULL, 0 };
# endif
#else
{ PCRE_EXTRA_CALLOUT_DATA, NULL, 0, NULL, NULL };
#endif
cod.subj_start = subj_start;
memcpy(subj, ocaml_subj, len);
Begin_roots4(v_rex, v_cof, v_substrings, v_ovec);
Begin_roots1(v_subj);
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) {
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_EXTRA_MATCH_LIMIT_RECURSION
new_extra.match_limit_recursion = extra->match_limit_recursion;
#endif
}
if (is_dfa) {
workspace_len = Wosize_val(v_workspace);
workspace = caml_stat_alloc(sizeof(int) * workspace_len);
ret =
pcre_dfa_exec(code, extra, subj, len, pos, opt, ovec, ovec_len,
(int *) &Field(v_workspace, 0), workspace_len);
} else
ret =
pcre_exec(code, &new_extra, subj, len, pos, opt, ovec, ovec_len);
caml_stat_free(subj);
End_roots();
if (ret < 0) {
if (is_dfa) caml_stat_free(workspace);
caml_stat_free(ovec);
if (ret == PCRE_ERROR_CALLOUT) caml_raise(cod.v_exn);
else handle_exec_error("pcre_exec_stub(callout)", ret);
} else {
handle_pcre_exec_result(ovec, v_ovec, ovec_len, subj_start, ret);
if (is_dfa) {
caml_int_ptr ocaml_workspace_dst =
(caml_int_ptr) &Field(v_workspace, 0);
const int *workspace_src = workspace;
const int *workspace_src_stop = workspace + workspace_len;
while (workspace_src != workspace_src_stop) {
*ocaml_workspace_dst = *workspace_src;
ocaml_workspace_dst++;
workspace_src++;
}
caml_stat_free(workspace);
}
caml_stat_free(ovec);
}
}
}
return Val_unit;
}
CAMLprim value pcre_exec_stub(
intnat v_opt, value v_rex, intnat v_pos, intnat v_subj_start, value v_subj,
value v_ovec, value v_maybe_cof)
{
return pcre_exec_stub0(v_opt, v_rex, v_pos, v_subj_start, v_subj,
v_ovec, v_maybe_cof, (value) NULL);
}
/* 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_stub0(
Int_val(argv[0]), argv[1], Int_val(argv[2]), Int_val(argv[3]),
argv[4], argv[5], argv[6], (value) NULL);
}
/* Byte-code hook for pcre_dfa_exec_stub
Needed, because there are more than 5 arguments */
CAMLprim value pcre_dfa_exec_stub_bc(value *argv, int __unused argn)
{
return
pcre_exec_stub0(
Int_val(argv[0]), argv[1], Int_val(argv[2]), Int_val(argv[3]),
argv[4], argv[5], argv[6], argv[7]);
}
static struct custom_operations tables_ops = {
"pcre_ocaml_tables",
pcre_dealloc_tables,
custom_compare_default,
custom_hash_default,
custom_serialize_default,
custom_deserialize_default,
custom_compare_ext_default
};
/* 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 1_000_000 table set allocations (one
table set consumes 864 bytes -> maximum of 864_000_000 bytes unreclaimed
table sets) */
const value v_tables =
caml_alloc_custom(
&tables_ops, sizeof(struct pcre_ocaml_tables), 1, 1000000);
set_tables(v_tables, pcre_maketables());
return v_tables;
}
/* 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 intnat pcre_get_stringnumber_stub(value v_rex, value v_name)
{
const int ret = pcre_get_stringnumber(get_rex(v_rex), String_val(v_name));
if (ret == PCRE_ERROR_NOSUBSTRING)
caml_invalid_argument("Named string not found");
return ret;
}
CAMLprim value pcre_get_stringnumber_stub_bc(value v_rex, value v_name)
{
return Val_int(pcre_get_stringnumber_stub(v_rex, v_name));
}
/* 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) raise_internal_error("pcre_names_stub: namecount");
ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMEENTRYSIZE, &entry_size);
if (ret != 0) raise_internal_error("pcre_names_stub: nameentrysize");
ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMETABLE, &tbl_ptr);
if (ret != 0) raise_internal_error("pcre_names_stub: nametable");
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);
}
/* Generic stub for getting integer results from pcre_config */
static inline int pcre_config_int(int what)
{
int ret;
pcre_config(what, (void *) &ret);
return ret;
}
/* Generic stub for getting long integer results from pcre_config */
static inline int pcre_config_long(int what)
{
long ret;
pcre_config(what, (void *) &ret);
return ret;
}
/* 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);
}
CAMLexport value
unix_getsockopt_aux(char * name,
enum option_type ty, int level, int option,
value socket)
{
union option_value optval;
socklen_param_type optsize;
switch (ty) {
case TYPE_BOOL:
case TYPE_INT:
case TYPE_UNIX_ERROR:
optsize = sizeof(optval.i);
break;
case TYPE_LINGER:
optsize = sizeof(optval.lg);
break;
case TYPE_TIMEVAL:
optsize = sizeof(optval.tv);
break;
default:
unix_error(EINVAL, name, Nothing);
}
if (getsockopt(Int_val(socket), level, option,
(void *) &optval, &optsize) == -1)
uerror(name, Nothing);
switch (ty) {
case TYPE_BOOL:
return Val_bool(optval.i);
case TYPE_INT:
return Val_int(optval.i);
case TYPE_LINGER:
if (optval.lg.l_onoff == 0) {
return Val_int(0); /* None */
} else {
value res = alloc_small(1, 0); /* Some */
Init_field(res, 0, Val_int(optval.lg.l_linger));
return res;
}
case TYPE_TIMEVAL:
return copy_double((double) optval.tv.tv_sec
+ (double) optval.tv.tv_usec / 1e6);
case TYPE_UNIX_ERROR:
if (optval.i == 0) {
return Val_int(0); /* None */
} else {
value err, res;
err = unix_error_of_code(optval.i);
Begin_root(err);
res = alloc_small(1, 0); /* Some */
Init_field(res, 0, err);
End_roots();
return res;
}
default:
unix_error(EINVAL, name, Nothing);
}
}
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);
}