int
get_prefixed_iri(rdf_db *db, term_t t, atom_t *ap)
{ if ( PL_is_functor(t, FUNCTOR_colon2) )
{ term_t a = PL_new_term_ref();
atom_t alias, local, uri;
_PL_get_arg(1, t, a);
if ( !PL_get_atom(a, &alias) )
return FALSE;
_PL_get_arg(2, t, a);
if ( !PL_get_atom(a, &local) )
return FALSE;
if ( (uri = cached_expansion(alias, local)) )
{ *ap = uri;
return TRUE;
}
if ( (uri = expand_prefix(db, alias, local)) )
{ cache_expansion(alias, local, uri);
*ap = uri;
return TRUE;
}
}
return FALSE;
}
cairo_bool_t
plcairo_term_to_ps_level(term_t t,
cairo_ps_level_t *level)
{
atom_t a;
PLCAIRO_debug(" term: 0x%lx ---> cairo_ps_level_t: %p", t, level);
if ( !PL_get_atom(t, &a) )
{ return PL_type_error("CairoPSLevel", t);
}
if ( !ATOM_cairo_ps_level_2 )
{
ATOM_cairo_ps_level_2 = PL_new_atom("CAIRO_PS_LEVEL_2");
ATOM_cairo_ps_level_3 = PL_new_atom("CAIRO_PS_LEVEL_3");
}
if ( a == ATOM_cairo_ps_level_2 )
{ *level = CAIRO_PS_LEVEL_2;
}
else if ( a == ATOM_cairo_ps_level_3 )
{ *level = CAIRO_PS_LEVEL_3;
}
else
{ return PL_domain_error("CairoPSLevel", t);
}
return TRUE;
}
static const uri_component_ranges *
base_ranges(term_t t)
{ atom_t a;
if ( PL_get_atom(t, &a) )
{ base_cache *base = myBase();
if ( base->atom != a )
{ size_t len;
pl_wchar_t *s;
if ( base->atom )
{ PL_unregister_atom(base->atom);
PL_free(base->text);
}
if ( !PL_get_wchars(t, &len, &s, CVT_ATOM|BUF_MALLOC) )
return NULL;
base->atom = a;
PL_register_atom(a);
base->text = s;
parse_uri(&base->ranges, len, s);
}
return &base->ranges;
} else
{ type_error("atom", t);
return NULL;
}
}
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;
}
static int
get_order_table(term_t handle, OrdTable *t)
{ atom_t name;
OrdTable ot;
if ( PL_get_atom(handle, &name) &&
(ot = findOrdTable(name)) )
{ *t = ot;
return TRUE;
}
return FALSE;
}
int
query_loop(atom_t goal, int loop)
{ GET_LD
int rc;
int clear_stacks = (LD->query == NULL);
do
{ fid_t fid;
qid_t qid = 0;
term_t except = 0;
predicate_t p;
if ( !resetProlog(clear_stacks) )
goto error;
if ( !(fid = PL_open_foreign_frame()) )
goto error;
p = PL_pred(PL_new_functor(goal, 0), MODULE_system);
if ( (qid = PL_open_query(MODULE_system, PL_Q_NORMAL, p, 0)) )
{ rc = PL_next_solution(qid);
} else
{ error:
except = exception_term;
rc = FALSE; /* Won't get any better */
break;
}
if ( !rc && (except = PL_exception(qid)) )
{ atom_t a;
tracemode(FALSE, NULL);
debugmode(DBG_OFF, NULL);
setPrologFlagMask(PLFLAG_LASTCALL);
if ( PL_get_atom(except, &a) && a == ATOM_aborted )
{
#ifdef O_DEBUGGER
callEventHook(PLEV_ABORT);
#endif
printMessage(ATOM_informational, PL_ATOM, ATOM_aborted);
}
}
if ( qid ) PL_close_query(qid);
if ( fid ) PL_discard_foreign_frame(fid);
if ( !except )
break;
} while(loop);
return rc;
}
static foreign_t
pl_tipc_bind(term_t Socket, term_t Address, term_t opt)
{ struct sockaddr_tipc sockaddr;
size_t addrlen = sizeof(sockaddr);
int socket;
atom_t a;
int arity;
memset(&sockaddr, 0, sizeof(sockaddr));
if ( !tipc_get_socket(Socket, &socket) ||
!nbio_get_tipc_sockaddr(Address, &sockaddr) )
return FALSE;
if ( PL_get_name_arity(opt, &a, &arity) )
{ if ( (a == ATOM_scope || a == ATOM_no_scope) && arity == 1 )
{ atom_t val;
term_t a1 = PL_new_term_ref();
if (PL_get_arg(1, opt, a1))
{ signed char ival = 0;
if ( !PL_get_atom(a1, &val) )
return pl_error(NULL, 0, NULL, ERR_DOMAIN, a1, "atom");
if ( val == ATOM_zone )
ival = TIPC_ZONE_SCOPE;
else if ( val == ATOM_cluster )
ival = TIPC_CLUSTER_SCOPE;
else if ( val == ATOM_node )
ival = TIPC_NODE_SCOPE;
else if ( val == ATOM_all && a == ATOM_no_scope)
addrlen = 0;
else
return pl_error(NULL, 0, NULL, ERR_DOMAIN, a1, "node, cluster, or zone");
sockaddr.scope = (a == ATOM_scope) ? ival
: -ival;
if ( nbio_bind(socket, (struct sockaddr*)&sockaddr, addrlen) < 0 )
return FALSE;
}
} else
return pl_error(NULL, 0, NULL, ERR_ARGTYPE, 1, opt, "scoping option");
return TRUE;
}
return pl_error(NULL, 0, NULL, ERR_DOMAIN, a, "scope/1");
}
static int
restore_after_exception(term_t except)
{ GET_LD
atom_t a;
int rc = TRUE;
tracemode(FALSE, NULL);
debugmode(DBG_OFF, NULL);
setPrologFlagMask(PLFLAG_LASTCALL);
if ( PL_get_atom(except, &a) && a == ATOM_aborted )
{ rc = ( callEventHook(PLEV_ABORT) &&
printMessage(ATOM_informational, PL_ATOM, ATOM_aborted) );
}
return rc;
}
cairo_bool_t
plcairo_term_to_pattern_type(term_t t,
cairo_pattern_type_t *pattern_type)
{
atom_t a;
PLCAIRO_debug(" term: 0x%lx ---> cairo_pattern_type_t: %p", t, pattern_type);
if ( !PL_get_atom(t, &a) )
{ return PL_type_error("CairoPatternType", t);
}
if ( !ATOM_cairo_pattern_type_solid )
{
ATOM_cairo_pattern_type_solid = PL_new_atom("CAIRO_PATTERN_TYPE_SOLID");
ATOM_cairo_pattern_type_surface = PL_new_atom("CAIRO_PATTERN_TYPE_SURFACE");
ATOM_cairo_pattern_type_linear = PL_new_atom("CAIRO_PATTERN_TYPE_LINEAR");
ATOM_cairo_pattern_type_radial = PL_new_atom("CAIRO_PATTERN_TYPE_RADIAL");
ATOM_cairo_pattern_type_mesh = PL_new_atom("CAIRO_PATTERN_TYPE_MESH");
ATOM_cairo_pattern_type_raster_source = PL_new_atom("CAIRO_PATTERN_TYPE_RASTER_SOURCE");
}
if ( a == ATOM_cairo_pattern_type_solid )
{ *pattern_type = CAIRO_PATTERN_TYPE_SOLID;
}
else if ( a == ATOM_cairo_pattern_type_surface )
{ *pattern_type = CAIRO_PATTERN_TYPE_SURFACE;
}
else if ( a == ATOM_cairo_pattern_type_linear )
{ *pattern_type = CAIRO_PATTERN_TYPE_LINEAR;
}
else if ( a == ATOM_cairo_pattern_type_radial )
{ *pattern_type = CAIRO_PATTERN_TYPE_RADIAL;
}
else if ( a == ATOM_cairo_pattern_type_mesh )
{ *pattern_type = CAIRO_PATTERN_TYPE_MESH;
}
else if ( a == ATOM_cairo_pattern_type_raster_source )
{ *pattern_type = CAIRO_PATTERN_TYPE_RASTER_SOURCE;
}
else
{ return PL_domain_error("CairoPatternType", t);
}
return TRUE;
}
cairo_bool_t
plcairo_term_to_filter(term_t t,
cairo_filter_t *filter)
{
atom_t a;
PLCAIRO_debug(" term: 0x%lx ---> cairo_filter_t: %p", t, filter);
if ( !PL_get_atom(t, &a) )
{ return PL_type_error("CairoFilter", t);
}
if ( !ATOM_cairo_filter_fast )
{
ATOM_cairo_filter_fast = PL_new_atom("CAIRO_FILTER_FAST");
ATOM_cairo_filter_good = PL_new_atom("CAIRO_FILTER_GOOD");
ATOM_cairo_filter_best = PL_new_atom("CAIRO_FILTER_BEST");
ATOM_cairo_filter_nearest = PL_new_atom("CAIRO_FILTER_NEAREST");
ATOM_cairo_filter_bilinear = PL_new_atom("CAIRO_FILTER_BILINEAR");
ATOM_cairo_filter_gaussian = PL_new_atom("CAIRO_FILTER_GAUSSIAN");
}
if ( a == ATOM_cairo_filter_fast )
{ *filter = CAIRO_FILTER_FAST;
}
else if ( a == ATOM_cairo_filter_good )
{ *filter = CAIRO_FILTER_GOOD;
}
else if ( a == ATOM_cairo_filter_best )
{ *filter = CAIRO_FILTER_BEST;
}
else if ( a == ATOM_cairo_filter_nearest )
{ *filter = CAIRO_FILTER_NEAREST;
}
else if ( a == ATOM_cairo_filter_bilinear )
{ *filter = CAIRO_FILTER_BILINEAR;
}
else if ( a == ATOM_cairo_filter_gaussian )
{ *filter = CAIRO_FILTER_GAUSSIAN;
}
else
{ return PL_domain_error("CairoFilter", t);
}
return TRUE;
}
static foreign_t
uri_encoded(term_t what, term_t qv, term_t enc)
{ pl_wchar_t *s;
size_t len;
atom_t w;
int flags;
if ( !PL_get_atom(what, &w) )
return type_error("atom", what);
if ( w == ATOM_query_value )
flags = ESC_QVALUE;
else if ( w == ATOM_fragment )
flags = ESC_FRAGMENT;
else if ( w == ATOM_path )
flags = ESC_PATH;
else
return domain_error("uri_component", what);
fill_flags();
if ( !PL_is_variable(qv) )
{ charbuf out;
int rc;
init_charbuf(&out);
if ( !add_encoded_term_charbuf(&out, qv, flags) )
{ free_charbuf(&out);
return FALSE;
}
rc = PL_unify_wchars(enc, PL_ATOM, out.here-out.base, out.base);
free_charbuf(&out);
return rc;
} else if ( PL_get_wchars(enc, &len, &s, CVT_ATOM|CVT_STRING|CVT_EXCEPTION) )
{ range r;
r.start = s;
r.end = s+len;
return unify_decoded_atom(qv, &r, flags);
} else
{ return FALSE;
}
}
static int
get_max_chr(term_t t, int *maxchr)
{ atom_t a;
if ( PL_get_atom(t, &a) )
{ if ( a == ATOM_iso_latin_1 )
*maxchr = 0xff;
else if ( a == ATOM_utf8 )
*maxchr = 0x7ffffff;
else if ( a == ATOM_unicode )
*maxchr = 0xffff;
else if ( a == ATOM_ascii )
*maxchr = 0x7f;
else
return sgml2pl_error(ERR_DOMAIN, "encoding", t);
return TRUE;
}
return sgml2pl_error(ERR_TYPE, "atom", t);
}
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
get_lang_stemmer(term_t t, struct sb_stemmer **stemmer)
{ stem_cache *cache = get_cache();
atom_t lang;
int i;
if ( !PL_get_atom(t, &lang) )
return type_error("atom", t);
for(i=0; i<CACHE_SIZE; i++)
{ if ( cache->stemmers[i].language == lang )
{ *stemmer = cache->stemmers[i].stemmer;
return TRUE;
}
}
for(i=0; i<CACHE_SIZE; i++)
{ if ( !cache->stemmers[i].stemmer )
{ struct sb_stemmer *st;
if ( !(st= sb_stemmer_new(PL_atom_chars(lang), NULL)) )
{ if ( errno == ENOMEM )
return resource_error("memory");
else
return domain_error("snowball_algorithm", t);
}
cache->stemmers[i].language = lang;
cache->stemmers[i].stemmer = st;
PL_register_atom(cache->stemmers[i].language);
*stemmer = cache->stemmers[i].stemmer;
return TRUE;
}
}
assert(0); /* TBD: clean cache */
return FALSE;
}
cairo_bool_t
plcairo_term_to_extend(term_t t,
cairo_extend_t *extend)
{
atom_t a;
PLCAIRO_debug(" term: 0x%lx ---> cairo_extend_t: %p", t, extend);
if ( !PL_get_atom(t, &a) )
{ return PL_type_error("CairoExtend", t);
}
if ( !ATOM_cairo_extend_none )
{
ATOM_cairo_extend_none = PL_new_atom("CAIRO_EXTEND_NONE");
ATOM_cairo_extend_repeat = PL_new_atom("CAIRO_EXTEND_REPEAT");
ATOM_cairo_extend_reflect = PL_new_atom("CAIRO_EXTEND_REFLECT");
ATOM_cairo_extend_pad = PL_new_atom("CAIRO_EXTEND_PAD");
}
if ( a == ATOM_cairo_extend_none )
{ *extend = CAIRO_EXTEND_NONE;
}
else if ( a == ATOM_cairo_extend_repeat )
{ *extend = CAIRO_EXTEND_REPEAT;
}
else if ( a == ATOM_cairo_extend_reflect )
{ *extend = CAIRO_EXTEND_REFLECT;
}
else if ( a == ATOM_cairo_extend_pad )
{ *extend = CAIRO_EXTEND_PAD;
}
else
{ return PL_domain_error("CairoExtend", t);
}
return TRUE;
}
static int
get_stream(term_t t, p_options *info, p_stream *stream)
{ atom_t a;
if ( PL_get_atom(t, &a) )
{ if ( a == ATOM_null )
{ stream->type = std_null;
return TRUE;
} else if ( a == ATOM_std )
{ stream->type = std_std;
return TRUE;
} else
{ return domain_error(t, "process_stream");
}
} else if ( PL_is_functor(t, FUNCTOR_pipe1) )
{ stream->term = PL_new_term_ref();
_PL_get_arg(1, t, stream->term);
stream->type = std_pipe;
info->pipes++;
return TRUE;
} else
return type_error(t, "process_stream");
}
static foreign_t
pl_rl_add_history(term_t text)
{ atom_t a;
static atom_t last = 0;
if ( PL_get_atom(text, &a) )
{ if ( a != last )
{ TCHAR *s;
if ( last )
PL_unregister_atom(last);
last = a;
PL_register_atom(last);
PL_get_wchars(text, NULL, &s, CVT_ATOM);
rlc_add_history(PL_current_console(), s);
}
return TRUE;
}
return FALSE;
}
static int
get_dst_arg(int i, term_t t, term_t a, int *val)
{ GET_LD
atom_t name;
_PL_get_arg(i, t, a);
if ( PL_get_atom(a, &name) )
{ if ( name == ATOM_true )
{ *val = TRUE;
return TRUE;
} else if ( name == ATOM_false )
{ *val = FALSE;
return TRUE;
} else if ( name == ATOM_minus )
{ *val = -1;
return TRUE;
}
} else if ( PL_is_variable(a) )
{ *val = -2;
return TRUE;
}
return PL_get_bool_ex(a, val); /* generate an error */
}
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 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);
}
word
pl_current_functor(term_t name, term_t arity, control_t h)
{ GET_LD
atom_t nm = 0;
size_t index;
int i, last=FALSE;
int ar;
fid_t fid;
switch( ForeignControl(h) )
{ case FRG_FIRST_CALL:
if ( PL_get_atom(name, &nm) &&
PL_get_integer(arity, &ar) )
return isCurrentFunctor(nm, ar) ? TRUE : FALSE;
if ( !(PL_is_integer(arity) || PL_is_variable(arity)) )
return PL_error("current_functor", 2, NULL, ERR_DOMAIN,
ATOM_integer, arity);
if ( !(PL_is_atom(name) || PL_is_variable(name)) )
return PL_error("current_functor", 2, NULL, ERR_DOMAIN,
ATOM_atom, name);
index = 1;
break;
case FRG_REDO:
PL_get_atom(name, &nm);
index = ForeignContextInt(h);
break;
case FRG_CUTTED:
default:
succeed;
}
fid = PL_open_foreign_frame();
LOCK();
for(i=MSB(index); !last; i++)
{ size_t upto = (size_t)2<<i;
FunctorDef *b = GD->functors.array.blocks[i];
if ( upto >= GD->functors.highest )
{ upto = GD->functors.highest;
last = TRUE;
}
for(; index<upto; index++)
{ FunctorDef fd = b[index];
if ( fd && fd->arity > 0 && (!nm || nm == fd->name) )
{ if ( PL_unify_atom(name, fd->name) &&
PL_unify_integer(arity, fd->arity) )
{ UNLOCK();
ForeignRedoInt(index+1);
} else
{ PL_rewind_foreign_frame(fid);
}
}
}
}
UNLOCK();
return FALSE;
}
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
pl_tipc_setopt(term_t Socket, term_t opt)
{ int socket;
atom_t a;
int arity;
if ( !tipc_get_socket(Socket, &socket) )
return FALSE;
if ( PL_get_name_arity(opt, &a, &arity) )
{ if ( a == ATOM_importance && arity == 1 )
{ atom_t val;
term_t a1 = PL_new_term_ref();
int ival = TIPC_LOW_IMPORTANCE;
if (PL_get_arg(1, opt, a1))
{ if(!PL_get_atom(a1, &val) )
return pl_error(NULL, 0, NULL, ERR_DOMAIN, a1, "atom");
if(val == ATOM_low)
ival = TIPC_LOW_IMPORTANCE;
else if(val == ATOM_medium)
ival = TIPC_MEDIUM_IMPORTANCE;
else if(val == ATOM_high)
ival = TIPC_HIGH_IMPORTANCE;
else if(val == ATOM_critical)
ival = TIPC_CRITICAL_IMPORTANCE;
else
return pl_error(NULL, 0, NULL, ERR_DOMAIN, a1, "low, medium, high, or critical");
return((tipc_setopt(socket, NB_TIPC_IMPORTANCE, ival) == 0) ? TRUE : FALSE);
}
}
if ( ((a == ATOM_dest_droppable) ||
(a == ATOM_src_droppable)) && arity == 1 )
{ int val;
term_t a1 = PL_new_term_ref();
int option = (a == ATOM_dest_droppable) ? NB_TIPC_DEST_DROPPABLE
: NB_TIPC_SRC_DROPPABLE;
if (PL_get_arg(1, opt, a1))
{ if(!PL_get_bool(a1, &val) )
return pl_error(NULL, 0, NULL, ERR_DOMAIN, a1, "boolean");
return((tipc_setopt(socket, option, val) == 0) ? TRUE : FALSE);
}
}
if ( a == ATOM_conn_timeout && arity == 1 )
{ double val;
int ival;
term_t a1 = PL_new_term_ref();
if (PL_get_arg(1, opt, a1))
{ if(!PL_get_float(a1, &val) || val < 0)
return pl_error(NULL, 0, NULL, ERR_DOMAIN, a1, "float");
ival = val * 1000; // time is in milliseconds
return((tipc_setopt(socket, NB_TIPC_CONN_TIMEOUT, ival) == 0) ? TRUE : FALSE);
}
}
if ( a == ATOM_nodelay && arity <= 1 )
{ int enable, rc;
if ( arity == 0 )
{ enable = TRUE;
} else /*if ( arity == 1 )*/
{ term_t a = PL_new_term_ref();
_PL_get_arg(1, opt, a);
if ( !PL_get_bool(a, &enable) )
return pl_error(NULL, 0, NULL, ERR_DOMAIN, a, "boolean");
}
if ( (rc=nbio_setopt(socket, TCP_NO_DELAY, enable) == 0) )
return TRUE;
if ( rc == -2 )
return pl_error(NULL, 0, NULL, ERR_DOMAIN, opt, "socket_option");
}
if ( a == ATOM_nonblock && arity == 0 )
return((nbio_setopt(socket, TCP_NONBLOCK) == 0) ? TRUE : FALSE );
if ( a == ATOM_dispatch && arity == 1 )
{ int val;
term_t a1 = PL_new_term_ref();
if ( PL_get_arg(1, opt, a1) && PL_get_bool(a1, &val) )
{ if ( nbio_setopt(socket, TCP_DISPATCH, val) == 0 )
return TRUE;
return FALSE;
}
}
}
return pl_error(NULL, 0, NULL, ERR_DOMAIN, opt, "socket_option");
}
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;
}
