static int
parse_set(OrdTable ot, atom_t name, term_t set)
{ term_t c = PL_new_term_ref();
int type;
if ( name == ATOM_break )
type = ORD_BREAK;
else if ( name == ATOM_ignore )
type = ORD_IGNORE;
else if ( name == ATOM_tag )
type = ORD_TAG;
else
return FALSE;
while(PL_get_list(set, c, set))
{ int i;
if ( !get_char(c, &i) )
return FALSE;
ORD(ot, i) = type;
}
return PL_get_nil(set);
}
static int
process_console_options(rlc_console_attr *attr, term_t options)
{ term_t tail = PL_copy_term_ref(options);
term_t opt = PL_new_term_ref();
while(PL_get_list(tail, opt, tail))
{ atom_t name;
const char *s;
int arity;
if ( !PL_get_name_arity(opt, &name, &arity) )
return type_error(opt, "compound");
s = PL_atom_chars(name);
if ( streq(s, "registry_key") && arity == 1 )
{ TCHAR *key;
if ( !get_chars_arg_ex(1, opt, &key) )
return FALSE;
attr->key = key;
} else
return domain_error(opt, "window_option");
}
if ( !PL_get_nil(tail) )
return type_error(tail, "list");
return TRUE;
}
static int
parse_options(term_t options, p_options *info)
{ term_t tail = PL_copy_term_ref(options);
term_t head = PL_new_term_ref();
term_t arg = PL_new_term_ref();
info->window = MAYBE;
while(PL_get_list(tail, head, tail))
{ atom_t name;
int arity;
if ( !PL_get_name_arity(head, &name, &arity) || arity != 1 )
return type_error(head, "option");
_PL_get_arg(1, head, arg);
if ( name == ATOM_stdin )
{ if ( !get_stream(arg, info, &info->streams[0]) )
return FALSE;
} else if ( name == ATOM_stdout )
{ if ( !get_stream(arg, info, &info->streams[1]) )
return FALSE;
} else if ( name == ATOM_stderr )
{ if ( !get_stream(arg, info, &info->streams[2]) )
return FALSE;
} else if ( name == ATOM_process )
{ info->pid = PL_copy_term_ref(arg);
} else if ( name == ATOM_detached )
{ if ( !PL_get_bool(arg, &info->detached) )
return type_error(arg, "boolean");
} else if ( name == ATOM_cwd )
{
#ifdef __WINDOWS__
if ( !PL_get_wchars(arg, NULL, &info->cwd,
CVT_ATOM|CVT_STRING|CVT_EXCEPTION|BUF_MALLOC) )
return FALSE;
#else
if ( !PL_get_chars(arg, &info->cwd,
CVT_ATOM|CVT_STRING|CVT_EXCEPTION|BUF_MALLOC|REP_FN) )
return FALSE;
#endif
} else if ( name == ATOM_window )
{ if ( !PL_get_bool(arg, &info->window) )
return type_error(arg, "boolean");
} else if ( name == ATOM_env )
{ if ( !parse_environment(arg, info) )
return FALSE;
} else
return domain_error(head, "process_option");
}
if ( !PL_get_nil(tail) )
return type_error(tail, "list");
return TRUE;
}
static int
parse_environment(term_t t, p_options *info)
{ term_t tail = PL_copy_term_ref(t);
term_t head = PL_new_term_ref();
term_t tmp = PL_new_term_ref();
ecbuf *eb = &info->envbuf;
int count = 0;
#ifndef __WINDOWS__
echar *q;
char **ep;
int c = 0;
#endif
assert(eb->size == 0);
assert(eb->allocated == 0);
assert(eb->buffer == NULL);
while( PL_get_list(tail, head, tail) )
{ echar *s;
size_t len;
if ( !PL_is_functor(head, FUNCTOR_eq2) )
return type_error(head, "environment_variable");
if ( !get_echars_arg_ex(1, head, tmp, &s, &len) )
return FALSE;
add_ecbuf(eb, s, len);
add_ecbuf(eb, ECHARS("="), 1);
if ( !get_echars_arg_ex(2, head, tmp, &s, &len) )
return FALSE;
add_ecbuf(eb, s, len);
add_ecbuf(eb, ECHARS("\0"), 1);
count++;
}
if ( !PL_get_nil(tail) )
return type_error(tail, "list");
#ifdef __WINDOWS__
add_ecbuf(eb, ECHARS("\0"), 1);
#else
info->envp = PL_malloc((count+1)*sizeof(char*));
for(ep=info->envp, c=0, q=eb->buffer; c<count; c++, ep++)
{ *ep = q;
q += strlen(q)+1;
}
assert((size_t)(q-eb->buffer) == eb->size);
*ep = NULL;
#endif
return TRUE;
}
// parse a list of Prolog terms and add arguments to an OSC message
static int add_msg_args(lo_message msg, term_t list)
{
term_t head=PL_new_term_ref();
// copy term ref so as not to modify original
list=PL_copy_term_ref(list);
while (PL_get_list(list,head,list)) {
atom_t name;
int arity;
const char *type;
if (!PL_get_name_arity(head,&name,&arity)) return type_error(head,"term");
type=PL_atom_chars(name);
switch (arity) {
case 1: {
term_t a1=PL_new_term_ref();
PL_get_arg(1,head,a1);
if (!strcmp(type,"int")) {
int x;
if (!PL_get_integer(a1,&x)) return type_error(a1,"integer");
lo_message_add_int32(msg,x);
} else if (!strcmp(type,"double")) {
double x;
if (!PL_get_float(a1,&x)) return type_error(a1,"float");
lo_message_add_double(msg,x);
} else if (!strcmp(type,"string")) {
char *x;
if (!PL_get_chars(a1,&x,CVT_ATOM|CVT_STRING)) return type_error(a1,"string");
lo_message_add_string(msg,x);
} else if (!strcmp(type,"symbol")) {
char *x;
if (!PL_get_chars(a1,&x,CVT_ATOM)) return type_error(a1,"atom");
lo_message_add_symbol(msg,x);
} else if (!strcmp(type,"float")) {
double x;
if (!PL_get_float(a1,&x)) return type_error(a1,"float");
lo_message_add_float(msg,(float)x);
}
break;
}
case 0: {
if (!strcmp(type,"true")) lo_message_add_true(msg);
else if (!strcmp(type,"false")) lo_message_add_false(msg);
else if (!strcmp(type,"nil")) lo_message_add_nil(msg);
else if (!strcmp(type,"inf")) lo_message_add_infinitum(msg);
break;
}
}
}
if (!PL_get_nil(list)) return type_error(list,"nil");
return TRUE;
}
static int
sha_options(term_t options, optval *result)
{ term_t opts = PL_copy_term_ref(options);
term_t opt = PL_new_term_ref();
/* defaults */
memset(result, 0, sizeof(*result));
result->algorithm = ALGORITHM_SHA1;
result->digest_size = SHA1_DIGEST_SIZE;
while(PL_get_list(opts, opt, opts))
{ atom_t aname;
int arity;
if ( PL_get_name_arity(opt, &aname, &arity) && arity == 1 )
{ term_t a = PL_new_term_ref();
_PL_get_arg(1, opt, a);
if ( aname == ATOM_algorithm )
{ atom_t a_algorithm;
result->algorithm_term = a;
if ( !PL_get_atom(a, &a_algorithm) )
return pl_error(NULL, 0, NULL, ERR_TYPE, a, "algorithm");
if ( a_algorithm == ATOM_sha1 )
{ result->algorithm = ALGORITHM_SHA1;
result->digest_size = SHA1_DIGEST_SIZE;
} else if ( a_algorithm == ATOM_sha224 )
{ result->algorithm = ALGORITHM_SHA224;
result->digest_size = SHA224_DIGEST_SIZE;
} else if ( a_algorithm == ATOM_sha256 )
{ result->algorithm = ALGORITHM_SHA256;
result->digest_size = SHA256_DIGEST_SIZE;
} else if ( a_algorithm == ATOM_sha384 )
{ result->algorithm = ALGORITHM_SHA384;
result->digest_size = SHA384_DIGEST_SIZE;
} else if ( a_algorithm == ATOM_sha512 )
{ result->algorithm = ALGORITHM_SHA512;
result->digest_size = SHA512_DIGEST_SIZE;
} else
return pl_error(NULL, 0, NULL, ERR_DOMAIN, a, "algorithm");
}
} else
{ return pl_error(NULL, 0, NULL, ERR_TYPE, opt, "option");
}
}
if ( !PL_get_nil(opts) )
return pl_error("sha_hash", 1, NULL, ERR_TYPE, opts, "list");
return TRUE;
}
/** assign a tuple to something:
*/
static foreign_t python_assign_tuple(term_t t_lhs, term_t t_rhs) {
PyObject *e;
Py_ssize_t sz;
functor_t f;
e = term_to_python(t_rhs, true);
if (!e || !PyTuple_Check(e)) {
return -1;
}
sz = PyTuple_Size(e);
switch (PL_term_type(t_lhs)) {
case PL_VARIABLE:
return PL_unify(t_lhs, t_rhs);
case PL_ATOM:
return assign_python(py_Main, t_rhs, e);
case PL_TERM:
if (PL_get_functor(t_lhs, &f)) {
term_t targ = PL_new_term_ref();
// assign a tuple to a tuple
if (PL_functor_name(f) == ATOM_t && ((sz = PL_functor_arity(f)))) {
Py_ssize_t i;
for (i = 0; i < sz; i++) {
PL_get_arg(i + 1, t_lhs, targ);
assign_python(py_Main, targ, PyTuple_GetItem(e, i));
}
} else if (PL_functor_name(f) == ATOM_comma) {
int n = conj_size(t_lhs);
if (n != sz)
return -1;
return conj_copy(t_lhs, e, 0);
} else if (PL_functor_name(f) == ATOM_dot) { // vectors
size_t len;
term_t tail = PL_new_term_ref();
PL_skip_list(t_lhs, tail, &len);
if (!PL_get_nil(tail))
return -1;
term_t arg = tail;
size_t i;
for (i = 0; i < len; i++) {
if (!PL_get_list(t_rhs, arg, t_rhs)) {
return -1;
}
if (assign_python(py_Main, arg, PyTuple_GetItem(e, i)) < 0)
return -1;
}
}
}
}
return -1;
}
// parse a list of type terms and encode as a NULL terminated
// string where each character encodes the type of one argument.
static int get_types_list(term_t list, char *typespec, int len)
{
term_t head=PL_new_term_ref();
int count=0;
// copy term ref so as not to modify original
list=PL_copy_term_ref(list);
while (PL_get_list(list,head,list) && count<len) {
atom_t name;
int arity;
const char *type;
if (!PL_get_name_arity(head,&name,&arity)) return type_error(head,"term");
type=PL_atom_chars(name);
switch (arity) {
case 1: {
if (!strcmp(type,"int")) {
typespec[count++]='i';
} else if (!strcmp(type,"double")) {
typespec[count++]='d';
} else if (!strcmp(type,"string")) {
typespec[count++]='s';
} else if (!strcmp(type,"symbol")) {
typespec[count++]='S';
} else if (!strcmp(type,"float")) {
typespec[count++]='f';
}
break;
}
case 0: {
if (!strcmp(type,"true")) typespec[count++]='T';
else if (!strcmp(type,"false")) typespec[count++]='F';
else if (!strcmp(type,"nil")) typespec[count++]='N';
else if (!strcmp(type,"inf")) typespec[count++]='I';
break;
}
}
}
typespec[count]=0;
if (!PL_get_nil(list)) return type_error(list,"nil");
return TRUE;
}
static foreign_t
process_wait(term_t pid, term_t code, term_t options)
{ pid_t p;
wait_options opts;
term_t tail = PL_copy_term_ref(options);
term_t head = PL_new_term_ref();
term_t arg = PL_new_term_ref();
if ( !get_pid(pid, &p) )
return FALSE;
memset(&opts, 0, sizeof(opts));
while(PL_get_list(tail, head, tail))
{ atom_t name;
int arity;
if ( !PL_get_name_arity(head, &name, &arity) || arity != 1 )
return type_error(head, "option");
_PL_get_arg(1, head, arg);
if ( name == ATOM_timeout )
{ atom_t a;
if ( !(PL_get_atom(arg, &a) && a == ATOM_infinite) )
{ if ( !PL_get_float(arg, &opts.timeout) )
return type_error(arg, "timeout");
opts.has_timeout = TRUE;
}
} else if ( name == ATOM_release )
{ if ( !PL_get_bool(arg, &opts.release) )
return type_error(arg, "boolean");
if ( opts.release == FALSE )
return domain_error(arg, "true");
} else
return domain_error(head, "process_wait_option");
}
if ( !PL_get_nil(tail) )
return type_error(tail, "list");
return wait_for_pid(p, code, &opts);
}
static int
md5_options(term_t options, optval *result)
{ term_t opts = PL_copy_term_ref(options);
term_t opt = PL_new_term_ref();
/* defaults */
memset(result, 0, sizeof(*result));
result->encoding = REP_UTF8;
while(PL_get_list(opts, opt, opts))
{ atom_t aname;
size_t arity;
if ( PL_get_name_arity(opt, &aname, &arity) && arity == 1 )
{ term_t a = PL_new_term_ref();
_PL_get_arg(1, opt, a);
if ( aname == ATOM_encoding )
{ atom_t a_enc;
if ( !PL_get_atom_ex(a, &a_enc) )
return FALSE;
if ( a_enc == ATOM_utf8 )
result->encoding = REP_UTF8;
else if ( a_enc == ATOM_octet )
result->encoding = REP_ISO_LATIN_1;
else
return PL_domain_error("encoding", a);
}
} else
{ return PL_type_error("option", opt);
}
}
if ( !PL_get_nil(opts) )
return PL_type_error("list", opts);
return TRUE;
}
static foreign_t
pl_new_order_table(term_t name, term_t options)
{ OrdTable t = malloc(sizeof(ordtable));
term_t tail = PL_copy_term_ref(options);
term_t head = PL_new_term_ref();
exact_table(t);
if ( !PL_get_atom(name, &t->name) )
{ free(t);
return error(ERR_INSTANTIATION, "new_order_table/2", 1, name);
}
while(PL_get_list(tail, head, tail))
{ atom_t name;
int arity;
if ( PL_get_name_arity(head, &name, &arity) )
{ if ( name == ATOM_case_insensitive )
{ case_insensitive_table(t);
} else if ( name == ATOM_iso_latin_1 )
{ iso_latin_1_table(t);
} else if ( name == ATOM_iso_latin_1_case_insensitive )
{ iso_latin_1_case_table(t);
} else if ( name == ATOM_copy && arity == 1 )
{ term_t a = PL_new_term_ref();
OrdTable from;
_PL_get_arg(1, head, a);
if ( get_order_table(a, &from) )
{ copy_table(t, from);
} else
{ free(t);
return FALSE;
}
} else if ( arity == 1 )
{ fid_t fid = PL_open_foreign_frame();
term_t a = PL_new_term_ref();
_PL_get_arg(1, head, a);
if ( !parse_set(t, name, a) )
goto err1;
PL_close_foreign_frame(fid);
} else if ( name == ATOM_eq && arity == 2 )
{ fid_t fid = PL_open_foreign_frame();
term_t c = PL_new_term_ref();
int from, to;
if ( !PL_get_arg(1, head, c) || !get_char(c, &from) ||
!PL_get_arg(2, head, c) || !get_char(c, &to) )
{ free(t);
return FALSE;
}
ORD(t, from) = to;
PL_close_foreign_frame(fid);
} else
goto err1;
} else
{ err1:
free(t);
return error(ERR_INSTANTIATION, "new_order_table/2", 2, options);
}
}
if ( !PL_get_nil(tail) )
goto err1;
register_table(t);
PL_succeed;
}
bool
scan_options(term_t options, int flags, atom_t optype,
const opt_spec *specs, ...)
{ GET_LD
va_list args;
const opt_spec *s;
optvalue values[MAXOPTIONS];
term_t list = PL_copy_term_ref(options);
term_t head = PL_new_term_ref();
term_t tmp = PL_new_term_ref();
term_t val = PL_new_term_ref();
int n;
if ( truePrologFlag(PLFLAG_ISO) )
flags |= OPT_ALL;
va_start(args, specs);
for( n=0, s = specs; s->name; s++, n++ )
values[n].ptr = va_arg(args, void *);
va_end(args);
while ( PL_get_list(list, head, list) )
{ atom_t name;
int arity;
if ( PL_get_name_arity(head, &name, &arity) )
{ if ( name == ATOM_equals && arity == 2 )
{ _PL_get_arg(1, head, tmp);
if ( !PL_get_atom(tmp, &name) )
goto itemerror;
_PL_get_arg(2, head, val);
} else if ( arity == 1 )
{ _PL_get_arg(1, head, val);
} else if ( arity == 0 )
PL_put_atom(val, ATOM_true);
} else if ( PL_is_variable(head) )
{ return PL_error(NULL, 0, NULL, ERR_INSTANTIATION);
} else
{ itemerror:
return PL_error(NULL, 0, NULL, ERR_DOMAIN, optype, head);
}
for( n=0, s = specs; s->name; n++, s++ )
{ if ( s->name == name )
{ switch((s->type & OPT_TYPE_MASK))
{ case OPT_BOOL:
{ int bval;
if ( !PL_get_bool_ex(val, &bval) )
return FALSE;
*values[n].b = bval;
break;
}
case OPT_INT:
{ if ( !PL_get_integer_ex(val, values[n].i) )
return FALSE;
break;
}
case OPT_LONG:
{ if ( (s->type & OPT_INF) && PL_is_inf(val) )
*values[n].l = LONG_MAX;
else if ( !PL_get_long_ex(val, values[n].l) )
return FALSE;
break;
}
case OPT_NATLONG:
{ if ( !PL_get_long_ex(val, values[n].l) )
return FALSE;
if ( *(values[n].l) <= 0 )
return PL_error(NULL, 0, NULL, ERR_DOMAIN,
ATOM_not_less_than_one, val);
break;
}
case OPT_SIZE:
{ if ( (s->type & OPT_INF) && PL_is_inf(val) )
*values[n].sz = (size_t)-1;
else if ( !PL_get_size_ex(val, values[n].sz) )
return FALSE;
break;
}
case OPT_DOUBLE:
{ if ( !PL_get_float_ex(val, values[n].f) )
return FALSE;
break;
}
case OPT_STRING:
{ char *str;
if ( !PL_get_chars(val, &str, CVT_ALL|CVT_EXCEPTION) ) /* copy? */
return FALSE;
*values[n].s = str;
break;
}
case OPT_ATOM:
{ atom_t a;
if ( !PL_get_atom_ex(val, &a) )
return FALSE;
*values[n].a = a;
break;
}
#ifdef O_LOCALE
case OPT_LOCALE:
{ PL_locale *l;
PL_locale **lp = values[n].ptr;
if ( !getLocaleEx(val, &l) )
return FALSE;
*lp = l;
break;
}
#endif
case OPT_TERM:
{ *values[n].t = val;
val = PL_new_term_ref(); /* can't reuse anymore */
break;
}
default:
assert(0);
fail;
}
break;
}
}
if ( !s->name && (flags & OPT_ALL) )
goto itemerror;
}
if ( !PL_get_nil(list) )
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, list);
succeed;
}
static foreign_t
alarm4_gen(time_abs_rel abs_rel, term_t time, term_t callable,
term_t id, term_t options)
{ Event ev;
double t;
module_t m = NULL;
unsigned long flags = 0L;
if ( options )
{ term_t tail = PL_copy_term_ref(options);
term_t head = PL_new_term_ref();
while( PL_get_list(tail, head, tail) )
{ atom_t name;
int arity;
if ( PL_get_name_arity(head, &name, &arity) )
{ if ( arity == 1 )
{ term_t arg = PL_new_term_ref();
_PL_get_arg(1, head, arg);
if ( name == ATOM_remove )
{ int t = FALSE;
if ( !pl_get_bool_ex(arg, &t) )
return FALSE;
if ( t )
flags |= EV_REMOVE;
} else if ( name == ATOM_install )
{ int t = TRUE;
if ( !pl_get_bool_ex(arg, &t) )
return FALSE;
if ( !t )
flags |= EV_NOINSTALL;
}
}
}
}
if ( !PL_get_nil(tail) )
return pl_error(NULL, 0, NULL, ERR_ARGTYPE, 4, options, "list");
}
if ( !PL_get_float(time, &t) )
return pl_error(NULL, 0, NULL, ERR_ARGTYPE, 1,
time, "number");
if ( !(ev = allocEvent()) )
return FALSE;
if (abs_rel==TIME_REL)
setTimeEvent(ev, t);
else
setTimeEventAbs(ev,t);
if ( !unify_timer(id, ev) )
{ freeEvent(ev); /* not linked: no need to lock */
return FALSE;
}
ev->flags = flags;
PL_strip_module(callable, &m, callable);
ev->module = m;
ev->goal = PL_record(callable);
if ( !(ev->flags & EV_NOINSTALL) )
{ int rc;
if ( (rc=installEvent(ev)) != TRUE )
{ freeEvent(ev); /* not linked: no need to lock */
return alarm_error(id, rc);
}
}
return TRUE;
}
static foreign_t
pl_uuid(term_t UUID, term_t options)
{ unsigned int mode = UUID_MAKE_V1;
atom_t format = ATOM_atom;
uuid_t *uuid;
char *ns = NULL;
char *str = NULL;
int rc;
uuid_rc_t urc;
if ( !PL_get_nil(options) )
{ term_t tail = PL_copy_term_ref(options);
term_t head = PL_new_term_ref();
term_t arg = PL_new_term_ref();
while( PL_get_list(tail, head, tail) )
{ atom_t name;
size_t arity;
if ( !PL_get_name_arity(head, &name, &arity) || arity != 1 )
return PL_type_error("option", head);
_PL_get_arg(1, head, arg);
if ( name == ATOM_version )
{ int v;
if ( !PL_get_integer_ex(arg, &v) )
return FALSE;
switch(v)
{ case 1: mode = UUID_MAKE_V1; break;
case 2: mode = UUID_MAKE_MC; break;
case 3: mode = UUID_MAKE_V3; break;
case 4: mode = UUID_MAKE_V4; break;
case 5: mode = UUID_MAKE_V5; break;
default: return PL_domain_error("uuid_version", arg);
}
} else if ( name == ATOM_format )
{ if ( !PL_get_atom_ex(arg, &format) )
return FALSE;
if ( format != ATOM_atom && format != ATOM_integer )
return PL_domain_error("uuid_format", arg);
} else
{ char *newns = NULL;
if ( name == ATOM_dns )
{ newns = "ns:DNS";
} else if ( name == ATOM_url )
{ newns = "ns:URL";
} else if ( name == ATOM_oid )
{ newns = "ns:OID";
} else if ( name == ATOM_x500 )
{ newns = "ns:X500";
}
if ( newns )
{ ns = newns;
if ( !PL_get_chars(arg, &str, CVT_ATOM|CVT_EXCEPTION) )
return FALSE;
if ( mode == UUID_MAKE_V1 )
mode = UUID_MAKE_V3;
}
}
}
if ( !PL_get_nil_ex(tail) )
return FALSE;
}
switch(mode)
{ case UUID_MAKE_V1:
case UUID_MAKE_MC:
case UUID_MAKE_V4:
uuid_create(&uuid);
if ( (urc=uuid_make(uuid, mode)) != UUID_RC_OK )
return PL_warning("UUID: make: %s\n", uuid_error(urc));
break;
case UUID_MAKE_V3:
case UUID_MAKE_V5:
{ uuid_t *uuid_ns;
if ( !ns )
return PL_existence_error("uuid_context", options);
uuid_create(&uuid);
uuid_create(&uuid_ns);
uuid_load(uuid_ns, ns);
if ( (urc=uuid_make(uuid, mode, uuid_ns, str)) != UUID_RC_OK )
return PL_warning("UUID: make: %s\n", uuid_error(urc));
uuid_destroy(uuid_ns);
break;
}
default:
assert(0);
return FALSE;
}
if ( format == ATOM_atom )
{ char buf[UUID_LEN_STR+1];
void *ptr = buf;
size_t datalen = sizeof(buf);
if ( (urc=uuid_export(uuid, UUID_FMT_STR, &ptr, &datalen)) != UUID_RC_OK )
return PL_warning("UUID: export: %s\n", uuid_error(urc));
rc = PL_unify_chars(UUID, PL_ATOM|REP_ISO_LATIN_1, (size_t)-1, buf);
} else if ( format == ATOM_integer )
{ char buf[UUID_LEN_SIV+1];
void *ptr = buf;
size_t datalen = sizeof(buf);
term_t tmp = PL_new_term_ref();
if ( (urc=uuid_export(uuid, UUID_FMT_SIV, &ptr, &datalen)) != UUID_RC_OK )
return PL_warning("UUID: export: %s\n", uuid_error(urc));
rc = ( PL_chars_to_term(buf, tmp) &&
PL_unify(UUID, tmp)
);
} else
{ assert(0);
return FALSE;
}
uuid_destroy(uuid);
return rc;
}
static foreign_t
udp_receive(term_t Socket, term_t Data, term_t From, term_t options)
{ struct sockaddr_in sockaddr;
#ifdef __WINDOWS__
int alen = sizeof(sockaddr);
#else
socklen_t alen = sizeof(sockaddr);
#endif
int socket;
int flags = 0;
char buf[UDP_MAXDATA];
ssize_t n;
int as = PL_STRING;
if ( !PL_get_nil(options) )
{ term_t tail = PL_copy_term_ref(options);
term_t head = PL_new_term_ref();
term_t arg = PL_new_term_ref();
while(PL_get_list(tail, head, tail))
{ atom_t name;
int arity;
if ( PL_get_name_arity(head, &name, &arity) && arity == 1 )
{ _PL_get_arg(1, head, arg);
if ( name == ATOM_as )
{ atom_t a;
if ( !PL_get_atom(arg, &a) )
return pl_error(NULL, 0, NULL, ERR_TYPE, head, "atom");
if ( a == ATOM_atom )
as = PL_ATOM;
else if ( a == ATOM_codes )
as = PL_CODE_LIST;
else if ( a == ATOM_string )
as = PL_STRING;
else
return pl_error(NULL, 0, NULL, ERR_DOMAIN, arg, "as_option");
}
} else
return pl_error(NULL, 0, NULL, ERR_TYPE, head, "option");
}
if ( !PL_get_nil(tail) )
return pl_error(NULL, 0, NULL, ERR_TYPE, tail, "list");
}
if ( !tcp_get_socket(Socket, &socket) ||
!nbio_get_sockaddr(From, &sockaddr) )
return FALSE;
if ( (n=nbio_recvfrom(socket, buf, sizeof(buf), flags,
(struct sockaddr*)&sockaddr, &alen)) == -1 )
return nbio_error(errno, TCP_ERRNO);
if ( !PL_unify_chars(Data, as, n, buf) )
return FALSE;
return unify_address(From, &sockaddr);
}
static foreign_t
tcp_select(term_t Streams, term_t Available, term_t timeout)
{ fd_set fds;
struct timeval t, *to;
double time;
int n, max = 0, ret, min = 1000000;
fdentry *map = NULL;
term_t head = PL_new_term_ref();
term_t streams = PL_copy_term_ref(Streams);
term_t available = PL_copy_term_ref(Available);
term_t ahead = PL_new_term_ref();
int from_buffer = 0;
atom_t a;
FD_ZERO(&fds);
while( PL_get_list(streams, head, streams) )
{ IOSTREAM *s;
#ifdef __WINDOWS__
nbio_sock_t fd;
#else
int fd;
#endif
fdentry *e;
if ( !PL_get_stream_handle(head, &s) )
return FALSE;
#ifdef __WINDOWS__
fd = fdFromHandle(s->handle);
#else
fd = Sfileno(s);
#endif
PL_release_stream(s);
if ( fd < 0 || !is_socket_stream(s) )
{ return pl_error("tcp_select", 3, NULL, ERR_DOMAIN,
head, "socket_stream");
}
/* check for input in buffer */
if ( s->bufp < s->limitp )
{ if ( !PL_unify_list(available, ahead, available) ||
!PL_unify(ahead, head) )
return FALSE;
from_buffer++;
}
e = alloca(sizeof(*e));
e->fd = fd;
e->stream = PL_copy_term_ref(head);
e->next = map;
map = e;
#ifdef __WINDOWS__
FD_SET((SOCKET)fd, &fds);
#else
FD_SET(fd, &fds);
#endif
if ( fd > max )
max = fd;
if( fd < min )
min = fd;
}
if ( !PL_get_nil(streams) )
return pl_error("tcp_select", 3, NULL, ERR_TYPE, Streams, "list");
if ( from_buffer > 0 )
return PL_unify_nil(available);
if ( PL_get_atom(timeout, &a) && a == ATOM_infinite )
{ to = NULL;
} else
{ if ( !PL_get_float(timeout, &time) )
return pl_error("tcp_select", 3, NULL,
ERR_TYPE, timeout, "number");
if ( time >= 0.0 )
{ t.tv_sec = (int)time;
t.tv_usec = ((int)(time * 1000000) % 1000000);
} else
{ t.tv_sec = 0;
t.tv_usec = 0;
}
to = &t;
}
while( (ret=nbio_select(max+1, &fds, NULL, NULL, to)) == -1 &&
errno == EINTR )
{ fdentry *e;
if ( PL_handle_signals() < 0 )
return FALSE; /* exception */
FD_ZERO(&fds); /* EINTR may leave fds undefined */
for(e=map; e; e=e->next) /* so we rebuild it to be safe */
{ FD_SET((SOCKET)e->fd, &fds);
}
}
switch(ret)
{ case -1:
return pl_error("tcp_select", 3, NULL, ERR_ERRNO, errno, "select", "streams", Streams);
case 0: /* Timeout */
break;
default: /* Something happened -> check fds */
for(n=min; n <= max; n++)
{ if ( FD_ISSET(n, &fds) )
{ if ( !PL_unify_list(available, ahead, available) ||
!PL_unify(ahead, findmap(map, n)) )
return FALSE;
}
}
break;
}
return PL_unify_nil(available);
}
static foreign_t
udp_receive(term_t Socket, term_t Data, term_t From, term_t options)
{ struct sockaddr_in sockaddr;
#ifdef __WINDOWS__
int alen = sizeof(sockaddr);
#else
socklen_t alen = sizeof(sockaddr);
#endif
int socket;
int flags = 0;
char smallbuf[UDP_DEFAULT_BUFSIZE];
char *buf = smallbuf;
int bufsize = UDP_DEFAULT_BUFSIZE;
term_t varport = 0;
ssize_t n;
int as = PL_STRING;
int rc;
if ( !PL_get_nil(options) )
{ term_t tail = PL_copy_term_ref(options);
term_t head = PL_new_term_ref();
term_t arg = PL_new_term_ref();
while(PL_get_list(tail, head, tail))
{ atom_t name;
size_t arity;
if ( PL_get_name_arity(head, &name, &arity) && arity == 1 )
{ _PL_get_arg(1, head, arg);
if ( name == ATOM_as )
{ atom_t a;
if ( !PL_get_atom(arg, &a) )
return pl_error(NULL, 0, NULL, ERR_TYPE, head, "atom");
if ( a == ATOM_atom )
as = PL_ATOM;
else if ( a == ATOM_codes )
as = PL_CODE_LIST;
else if ( a == ATOM_string )
as = PL_STRING;
else
return pl_error(NULL, 0, NULL, ERR_DOMAIN, arg, "as_option");
} else if ( name == ATOM_max_message_size )
{ if ( !PL_get_integer(arg, &bufsize) )
return pl_error(NULL, 0, NULL, ERR_TYPE, arg, "integer");
if ( bufsize < 0 || bufsize > UDP_MAXDATA )
return pl_error(NULL, 0, NULL, ERR_DOMAIN, arg, "0 - 65535");
}
} else
return pl_error(NULL, 0, NULL, ERR_TYPE, head, "option");
}
if ( !PL_get_nil(tail) )
return pl_error(NULL, 0, NULL, ERR_TYPE, tail, "list");
}
if ( !tcp_get_socket(Socket, &socket) ||
!nbio_get_sockaddr(From, &sockaddr, &varport) )
return FALSE;
if ( bufsize > UDP_DEFAULT_BUFSIZE )
{ if ( !(buf = malloc(bufsize)) )
return pl_error(NULL, 0, NULL, ERR_RESOURCE, "memory");
}
if ( (n=nbio_recvfrom(socket, buf, bufsize, flags,
(struct sockaddr*)&sockaddr, &alen)) == -1 )
{ rc = nbio_error(errno, TCP_ERRNO);
goto out;
}
rc = ( PL_unify_chars(Data, as, n, buf) &&
unify_address(From, &sockaddr)
);
out:
if ( buf != smallbuf )
free(buf);
return rc;
}
