static int
put_write_options(term_t opts_in, write_options *options)
{ GET_LD
term_t newlist = PL_new_term_ref();
term_t precopt = PL_new_term_ref();
fid_t fid = PL_open_foreign_frame();
term_t head = PL_new_term_ref();
term_t tail = PL_copy_term_ref(opts_in);
term_t newhead = PL_new_term_ref();
term_t newtail = PL_copy_term_ref(newlist);
int rc = TRUE;
while(rc && PL_get_list(tail, head, tail))
{ if ( !PL_is_functor(head, FUNCTOR_priority1) )
rc = ( PL_unify_list(newtail, newhead, newtail) &&
PL_unify(newhead, head) );
}
if ( rc )
{ rc = ( PL_unify_list(newtail, head, newtail) &&
PL_unify_functor(head, FUNCTOR_priority1) &&
PL_get_arg(1, head, precopt) &&
PL_unify_nil(newtail) );
}
if ( rc )
{ options->write_options = newlist;
options->prec_opt = precopt;
}
PL_close_foreign_frame(fid);
return rc;
}
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 foreign_t
archive_property(term_t archive, term_t prop, term_t value)
{ archive_wrapper *ar;
atom_t pn;
const char *s;
if ( !get_archive(archive, &ar) ||
!PL_get_atom_ex(prop, &pn) )
return FALSE;
#ifdef HAVE_ARCHIVE_FILTER_COUNT
if ( pn == ATOM_filter )
{ int i, fcount = archive_filter_count(ar->archive);
term_t tail = PL_copy_term_ref(value);
term_t head = PL_new_term_ref();
for(i=0; i<fcount; i++)
{ s = archive_filter_name(ar->archive, i);
if ( !s || strcmp(s, "none") == 0 )
continue;
if ( !PL_unify_list(tail, head, tail) ||
!PL_unify_atom_chars(head, s) )
return FALSE;
}
return PL_unify_nil(tail);
}
#endif
return FALSE;
}
gboolean
plgi_gbytes_to_term(GBytes *bytes,
term_t t)
{
term_t list = PL_copy_term_ref(t);
term_t head = PL_new_term_ref();
const guint8 *data;
gsize size;
gint i;
PLGI_debug(" GBytes: %p ---> term: 0x%lx", bytes, t);
data = g_bytes_get_data(bytes, &size);
for ( i = 0; i < size; i++ )
{ term_t a = PL_new_term_ref();
guint8 v = data[i];
if ( !plgi_guint8_to_term(v, a) )
{ return FALSE;
}
if ( !(PL_unify_list(list, head, list) &&
PL_unify(head, a)) )
{ return FALSE;
}
}
if ( !PL_unify_nil(list) )
{ return FALSE;
}
return TRUE;
}
static int
get_option(term_t t, int *opt)
{ term_t tail = PL_copy_term_ref(t);
term_t head = PL_new_term_ref();
char *s;
int option = 0;
while( PL_get_list_ex(tail, head, tail) )
{ if ( PL_get_chars(head, &s, CVT_ATOM|CVT_EXCEPTION) )
{ if ( streq(s, "cons" ) ) option |= LOG_CONS;
else if ( streq(s, "ndelay") ) option |= LOG_NDELAY;
else if ( streq(s, "nowait") ) option |= LOG_NOWAIT;
else if ( streq(s, "odelay") ) option |= LOG_ODELAY;
#ifdef LOG_PERROR
else if ( streq(s, "perror") ) option |= LOG_PERROR;
#endif
else if ( streq(s, "pid") ) option |= LOG_PID;
else return PL_domain_error("syslog_option", head);
} else
return FALSE;
}
if ( PL_get_nil_ex(tail) )
{ *opt = option;
return TRUE;
}
return FALSE;
}
static int get_show_map(term_t t, int *map) {
int rc;
term_t tail = PL_copy_term_ref(t);
term_t head = PL_new_term_ref();
*map = 0;
while (PL_get_list(tail, head, tail)) {
atom_t a;
if (!(rc = PL_get_atom_ex(head, &a))) {
goto out;
}
if (a == ATOM_atoms) {
*map |= clingo_show_type_atoms;
} else if (a == ATOM_terms) {
*map |= clingo_show_type_terms;
} else if (a == ATOM_shown) {
*map |= clingo_show_type_shown;
} else if (a == ATOM_csp) {
*map |= clingo_show_type_csp;
} else if (a == ATOM_comp) {
*map |= clingo_show_type_complement;
} else {
rc = PL_domain_error("clingo_show", head);
goto out;
}
}
if (!(rc = PL_get_nil_ex(tail))) {
goto out;
}
out:
return rc;
}
gboolean
plgi_term_to_gbytes(term_t t,
GBytes **bytes)
{
GBytes *bytes0;
term_t list = PL_copy_term_ref(t);
term_t head = PL_new_term_ref();
guint8 *data;
gsize len;
gint i = 0;
if ( PL_skip_list(list, 0, &len) != PL_LIST )
{ return PL_type_error("list", t);
}
data = g_malloc0(len);
while ( PL_get_list(list, head, list) )
{ guint8 byte;
if ( !plgi_term_to_guint8(head, &byte) )
{ g_free(data);
return FALSE;
}
data[i++] = byte;
}
bytes0 = g_bytes_new_take(data, len);
PLGI_debug(" term: 0x%lx ---> GBytes: %p", t, bytes0);
*bytes = bytes0;
return TRUE;
}
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 foreign_t
pl_group_info(term_t group, term_t info)
{ int gid;
struct group grp, *pgrp;
char buf[1000];
char *name;
term_t members = PL_new_term_ref();
term_t tail = PL_copy_term_ref(members);
term_t head = PL_new_term_ref();
char **memp;
if ( PL_get_integer(group, &gid) )
{ again1:
errno = 0;
if ( getgrgid_r(gid, &grp, buf, sizeof(buf), &pgrp) != 0 )
{ if ( errno == EINTR )
{ if ( PL_handle_signals() < 0 )
return FALSE;
goto again1;
}
return error(errno, "info", "group", group);
}
} else if ( PL_get_chars(group, &name, CVT_ATOMIC|REP_MB) )
{ again2:
errno = 0;
if ( getgrnam_r(name, &grp, buf, sizeof(buf), &pgrp) != 0 )
{ if ( errno == EINTR )
{ if ( PL_handle_signals() < 0 )
return FALSE;
goto again2;
}
return error(errno, "info", "group", group);
}
} else
{ return PL_type_error("group", group);
}
if ( !pgrp )
return PL_existence_error("group", group);
for(memp=pgrp->gr_mem; *memp; memp++)
{ if ( !PL_unify_list(tail, head, tail) ||
!PL_unify_chars(head, PL_ATOM|REP_MB, -1, *memp) )
return FALSE;
}
if ( !PL_unify_nil(tail) )
return FALSE;
return PL_unify_term(info,
PL_FUNCTOR_CHARS, "group_info", 4,
PL_MBCHARS, pgrp->gr_name,
PL_MBCHARS, pgrp->gr_passwd,
PL_INT, (int)pgrp->gr_gid,
PL_TERM, members
);
}
/********************
* get_field_names
********************/
static int
get_field_names(context_t *ctx, term_t pl_fields)
{
#define MAX_LENGTH 64 /* max length of a field name */
term_t pl_list, pl_head;
int i, n, left, size;
size_t dummy;
char *p, *field;
if ((n = list_length(pl_fields)) < 0)
return EINVAL;
size = n * sizeof(ctx->fields[0]) + n * MAX_LENGTH;
if ((ctx->fields = malloc(size)) == NULL)
return ENOMEM;
memset(ctx->fields, 0, size);
ctx->nfield = n;
p = ((char *)ctx->fields) + n * sizeof(ctx->fields[0]);
left = size - n * sizeof(ctx->fields[0]);
pl_list = PL_copy_term_ref(pl_fields); /* XXX is this really needed? */
pl_head = PL_new_term_ref();
for (i = 0; i < n && PL_get_list(pl_list, pl_head, pl_list); i++) {
switch (PL_term_type(pl_head)) {
case PL_ATOM:
if (!PL_get_atom_chars(pl_head, &field))
goto fail;
break;
case PL_STRING:
if (!PL_get_string_chars(pl_head, &field, &dummy))
goto fail;
break;
default:
goto fail;
}
ctx->fields[i] = p;
size = snprintf(p, left, "%s", field);
if (size + 1 > left)
goto fail;
p += size + 1;
left -= size + 1;
}
return 0;
fail:
if (ctx->fields != NULL) {
free(ctx->fields);
ctx->fields = NULL;
}
return EINVAL;
}
static foreign_t
uri_query_components(term_t string, term_t list)
{ pl_wchar_t *s;
size_t len;
if ( PL_get_wchars(string, &len, &s, CVT_ATOM|CVT_STRING|CVT_LIST) )
{ return unify_query_string_components(list, len, s);
} else if ( PL_is_list(list) )
{ term_t tail = PL_copy_term_ref(list);
term_t head = PL_new_term_ref();
term_t nv = PL_new_term_refs(2);
charbuf out;
int rc;
fill_flags();
init_charbuf(&out);
while( PL_get_list(tail, head, tail) )
{ atom_t fname;
int arity;
if ( PL_is_functor(head, FUNCTOR_equal2) ||
PL_is_functor(head, FUNCTOR_pair2) )
{ _PL_get_arg(1, head, nv+0);
_PL_get_arg(2, head, nv+1);
} else if ( PL_get_name_arity(head, &fname, &arity) && arity == 1 )
{ PL_put_atom(nv+0, fname);
_PL_get_arg(1, head, nv+1);
} else
{ free_charbuf(&out);
return type_error("name_value", head);
}
if ( out.here != out.base )
add_charbuf(&out, '&');
if ( !add_encoded_term_charbuf(&out, nv+0, ESC_QNAME) )
{ free_charbuf(&out);
return FALSE;
}
add_charbuf(&out, '=');
if ( !add_encoded_term_charbuf(&out, nv+1, ESC_QVALUE) )
{ free_charbuf(&out);
return FALSE;
}
}
rc = PL_unify_wchars(string, PL_ATOM, out.here-out.base, out.base);
free_charbuf(&out);
return rc;
} else
{ return PL_get_wchars(string, &len, &s,
CVT_ATOM|CVT_STRING|CVT_LIST|CVT_EXCEPTION);
}
return FALSE;
}
// 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
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;
}
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 foreign_t pl_clingo_ground(term_t ccontrol, term_t parts) {
clingo_env *ctl;
clingo_part_t *part_vec = NULL;
size_t plen = 0;
int rc;
if (!(rc = get_clingo(ccontrol, &ctl))) {
goto out;
}
switch (PL_skip_list(parts, 0, &plen)) {
case PL_LIST: {
term_t tail = PL_copy_term_ref(parts);
term_t head = PL_new_term_ref();
if (!(part_vec = malloc(sizeof(*part_vec) * plen))) {
rc = PL_resource_error("memory");
goto out;
}
memset(part_vec, 0, sizeof(*part_vec) * plen);
for (size_t i = 0; PL_get_list(tail, head, tail); i++) {
if (!(rc = get_params(head, &part_vec[i]))) {
goto out;
}
}
break;
}
default: {
rc = PL_type_error("list", parts);
goto out;
}
}
if (!(rc = clingo_status(clingo_control_ground(ctl->control, part_vec, plen,
call_function, ctl)))) {
goto out;
}
out:
if (part_vec) {
for (size_t i = 0; i < plen; i++) {
if (part_vec[i].params) {
free((void *)part_vec[i].params);
}
}
free(part_vec);
}
return rc;
}
static foreign_t
snowball_algorithms(term_t list)
{ term_t tail = PL_copy_term_ref(list);
term_t head = PL_new_term_ref();
const char **algos = sb_stemmer_list();
int i;
for(i=0; algos[i]; i++)
{ if ( !PL_unify_list(tail, head, tail) ||
!PL_unify_atom_chars(head, algos[i]) )
return FALSE;
}
return PL_unify_nil(tail);
}
/*************************
* swi_list_walk
*************************/
int
swi_list_walk(term_t list,
int (*callback)(term_t item, int i, void *data), void *data)
{
term_t pl_list, pl_head;
int i, err;
pl_list = PL_copy_term_ref(list);
pl_head = PL_new_term_ref();
for (i = err = 0; !err && PL_get_list(pl_list, pl_head, pl_list); i++)
err = callback(pl_head, i, data);
return err;
}
static foreign_t
pl_memberchk_eq(term_t element, term_t maybe_list)
{
term_t head = PL_new_term_ref(); /* variable for the elements */
term_t list = PL_copy_term_ref(maybe_list); /* copy as we need to write */
while( PL_get_list(list, head, list) )
{ if ( PL_compare(element,head) == 0 )
PL_succeed ;
}
PL_fail;
}
static foreign_t
pl_cgi_get_form(term_t form)
{ size_t len = 0;
char *data;
int must_free = FALSE;
term_t list = PL_copy_term_ref(form);
char *ct, *boundary;
if ( !get_raw_form_data(&data, &len, &must_free) )
return FALSE;
if ( (ct = getenv("CONTENT_TYPE")) &&
(boundary = strstr(ct, "boundary=")) )
{ boundary = strchr(boundary, '=')+1;
switch( break_multipart(data, len, boundary,
mp_add_to_form, (void *)list) )
{ case FALSE:
return FALSE;
case TRUE:
break;
default:
assert(0);
return FALSE;
}
} else
{ switch( break_form_argument(data, add_to_form, (void *)list) )
{ case FALSE:
return FALSE;
case TRUE:
break;
case ERROR_NOMEM:
return pl_error("cgi_get_form", 1, NULL,
ERR_RESOURCE, "memory");
case ERROR_SYNTAX_ERROR:
return pl_error("cgi_get_form", 1, NULL,
ERR_SYNTAX, "cgi_value");
default:
assert(0);
return FALSE;
}
}
if ( must_free )
free(data);
return PL_unify_nil(list);
}
// handle OSC message by calling the associated Prolog goal
static int prolog_handler(const char *path, const char *types, lo_arg **argv,
int argc, lo_message msg, void *user_data)
{
term_t goal = PL_new_term_ref();
term_t term0 = PL_new_term_refs(3);
term_t term1 = term0+1;
term_t term2 = term0+2;
term_t list;
int i, rc=0;
PL_recorded((record_t)user_data,goal); // retrieve the goal term
PL_put_term(term0,goal); // term_t goal encoded in user_data
PL_put_atom_chars(term1,path);
list = PL_copy_term_ref(term2);
for (i=0; i<argc; i++) {
term_t head=PL_new_term_ref();
term_t tail=PL_new_term_ref();
if (!PL_unify_list(list,head,tail)) PL_fail;
switch (types[i]) {
case 'c': rc=PL_unify_term(head,PL_FUNCTOR_CHARS,"char",1,PL_INT,(int)argv[i]->c); break;
case 'i': rc=PL_unify_term(head,PL_FUNCTOR_CHARS,"int",1,PL_INT,argv[i]->i); break;
case 'h': rc=PL_unify_term(head,PL_FUNCTOR_CHARS,"int64",1,PL_INT64,argv[i]->h); break;
case 'f': rc=PL_unify_term(head,PL_FUNCTOR_CHARS,"float",1,PL_FLOAT,(double)argv[i]->f); break;
case 'd': rc=PL_unify_term(head,PL_FUNCTOR_CHARS,"double",1,PL_DOUBLE,argv[i]->d); break;
case 's': rc=PL_unify_term(head,PL_FUNCTOR_CHARS,"string",1,PL_CHARS,&argv[i]->s); break;
case 'S': rc=PL_unify_term(head,PL_FUNCTOR_CHARS,"symbol",1,PL_CHARS,&argv[i]->S); break;
case 'T': rc=PL_unify_term(head,PL_FUNCTOR_CHARS,"true",0); break;
case 'F': rc=PL_unify_term(head,PL_FUNCTOR_CHARS,"false",0); break;
case 'N': rc=PL_unify_term(head,PL_FUNCTOR_CHARS,"nil",0); break;
case 'I': rc=PL_unify_term(head,PL_FUNCTOR_CHARS,"inf",0); break;
case 'b': rc=PL_unify_term(head,PL_FUNCTOR_CHARS,"blob",0); break;
case 't': rc=PL_unify_term(head,PL_FUNCTOR_CHARS,"timetag",2,
PL_INT64,(int64_t)argv[i]->t.sec,
PL_INT64,(int64_t)argv[i]->t.frac);
break;
case 'm': rc=PL_unify_term(head,PL_FUNCTOR_CHARS,"midi",4,
PL_INT,(int)argv[i]->m[0], PL_INT,(int)argv[i]->m[1],
PL_INT,(int)argv[i]->m[2], PL_INT,(int)argv[i]->m[3]);
break;
}
if (!rc) PL_fail;
list=tail;
}
return PL_unify_nil(list) && PL_call_predicate(NULL,PL_Q_NORMAL,call3,term0);
}
// 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;
}
void getQueryString(term_t t,char* buf)
{
term_t head = PL_new_term_ref();
term_t list = PL_copy_term_ref(t);
int i=0;
char* c;
while(PL_get_list(list,head,list))
{
if(!PL_is_variable(head))
{
PL_get_chars(head,&c,CVT_ATOM|BUF_DISCARDABLE);
buf[i]=c[0];
}
else
buf[i]='_';
++i;
}
buf[i]='\0';
}
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
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
unify_query_string_components(term_t list, size_t len, const pl_wchar_t *qs)
{ if ( len == 0 )
{ return PL_unify_nil(list);
} else
{ term_t tail = PL_copy_term_ref(list);
term_t head = PL_new_term_ref();
term_t eq = PL_new_term_refs(3);
term_t nv = eq+1;
const pl_wchar_t *end = &qs[len];
while(qs < end)
{ range name, value;
name.start = qs;
name.end = skip_not(qs, end, L"=");
if ( name.end < end )
{ value.start = name.end+1;
value.end = skip_not(value.start, end, L"&;");
qs = value.end+1;
} else
{ return syntax_error("illegal_uri_query");
}
PL_put_variable(nv+0);
PL_put_variable(nv+1);
unify_decoded_atom(nv+0, &name, ESC_QNAME);
unify_decoded_atom(nv+1, &value, ESC_QVALUE);
if ( !PL_cons_functor_v(eq, FUNCTOR_equal2, nv) ||
!PL_unify_list(tail, head, tail) ||
!PL_unify(head, eq) )
return FALSE;
}
return PL_unify_nil(tail);
}
}
static int unify_list_from_span(term_t list, clingo_symbol_t const *syms,
size_t slen) {
int rc;
term_t tail = PL_copy_term_ref(list);
term_t head = PL_new_term_ref();
term_t tmp = PL_new_term_ref();
clingo_symbol_t const *it, *ie;
for (it = syms, ie = it + slen; it != ie; ++it) {
PL_put_variable(tmp);
if (!(rc = (unify_value(tmp, *it) && PL_unify_list(tail, head, tail) &&
PL_unify(head, tmp)))) {
goto out;
}
}
if (!(rc = PL_unify_nil(tail))) {
goto out;
}
out:
return rc;
}
static foreign_t
pl_crypt(term_t passwd, term_t encrypted)
{ char *pw, *e;
char salt[20];
if ( !PL_get_chars(passwd, &pw, CVT_ATOM|CVT_STRING|CVT_LIST|BUF_RING) )
return pl_error("crypt", 2, NULL, ERR_ARGTYPE,
1, passwd, "text");
if ( PL_get_chars(encrypted, &e, CVT_ATOM|CVT_STRING|CVT_LIST|BUF_RING) )
{ char *s2;
if ( strncmp(e, "$1$", 3) == 0 ) /* MD5 Hash */
{ char *p = strchr(e+3, '$');
size_t slen;
if ( p && (slen=(size_t)(p-e-3)) < sizeof(salt) )
{ strncpy(salt, e+3, slen);
salt[slen] = 0;
s2 = md5_crypt(pw, salt);
return (strcmp(s2, e) == 0) ? TRUE : FALSE;
} else
{ Sdprintf("No salt???\n");
return FALSE;
}
} else
{ int rval;
salt[0] = e[0];
salt[1] = e[1];
salt[2] = '\0';
LOCK();
s2 = crypt(pw, salt);
rval = (strcmp(s2, e) == 0 ? TRUE : FALSE);
UNLOCK();
return rval;
}
} else
{ term_t tail = PL_copy_term_ref(encrypted);
term_t head = PL_new_term_ref();
int slen = 2;
int n;
int (*unify)(term_t t, const char *s) = PL_unify_list_codes;
char *s2;
int rval;
for(n=0; n<slen; n++)
{ if ( PL_get_list(tail, head, tail) )
{ int i;
char *t;
if ( PL_get_integer(head, &i) && i>=0 && i<=255 )
{ salt[n] = i;
} else if ( PL_get_atom_chars(head, &t) && t[1] == '\0' )
{ salt[n] = t[0];
unify = PL_unify_list_chars;
} else
{ return pl_error("crypt", 2, NULL, ERR_ARGTYPE,
2, head, "character");
}
if ( n == 1 && salt[0] == '$' && salt[1] == '1' )
slen = 3;
else if ( n == 2 && salt[2] == '$' )
slen = 8+3;
} else
break;
}
for( ; n < slen; n++ )
{ int c = 'a'+(int)(26.0*rand()/(RAND_MAX+1.0));
if ( rand() & 0x1 )
c += 'A' - 'a';
salt[n] = c;
}
salt[n] = 0;
LOCK();
if ( slen > 2 )
{ s2 = md5_crypt(pw, salt);
} else
{ s2 = crypt(pw, salt);
}
rval = (*unify)(encrypted, s2);
UNLOCK();
return rval;
}
}
NULL, /* seek64 */
};
/*******************************
* PROLOG CONNECTION *
*******************************/
#define COPY_FLAGS (SIO_INPUT|SIO_OUTPUT| \
SIO_TEXT| \
SIO_REPXML|SIO_REPPL|\
SIO_RECORDPOS)
static foreign_t
pl_http_chunked_open(term_t org, term_t new, term_t options)
{ term_t tail = PL_copy_term_ref(options);
term_t head = PL_new_term_ref();
chunked_context *ctx;
IOSTREAM *s, *s2;
int close_parent = FALSE;
int max_chunk_size = 0;
while(PL_get_list(tail, head, tail))
{ atom_t name;
int arity;
term_t arg = PL_new_term_ref();
if ( !PL_get_name_arity(head, &name, &arity) || arity != 1 )
return type_error(head, "option");
_PL_get_arg(1, head, arg);
static PyObject* pyswipl_run(PyObject* self_Py, PyObject* args_Py) {
char* goalString;
char* answer;
int answerCount;
PyObject* answerList_Py;
PyObject* answerString_Py;
PyObject* bindingList_Py;
PyObject* binding_Py;
term_t swipl_args;
term_t swipl_goalCharList;
term_t swipl_bindingList;
term_t swipl_head;
term_t swipl_list;
predicate_t swipl_predicate;
qid_t swipl_qid;
fid_t swipl_fid;
/**********************************************************/
/* The queryString_C should be a python string represting */
/* the query to be executed on the prolog system. */
/**********************************************************/
if(!PyArg_ParseTuple(args_Py, "s", &goalString))
return NULL;
else {
/**********************************************************/
/* Create a Python list to hold the lists of bindings. */
/**********************************************************/
//if ( answerList_Py != NULL )
// Py_DECREF(answerList_Py);
answerList_Py=PyList_New(0);
/**********************************************************/
/* Open a foreign frame and initialize the term refs. */
/**********************************************************/
swipl_fid=PL_open_foreign_frame();
swipl_head=PL_new_term_ref(); /* Used in unpacking the binding List */
swipl_args=PL_new_term_refs(2); /* The compound term for arguments to run/2 */
swipl_goalCharList=swipl_args; /* Alias for arg 1 */
swipl_bindingList=swipl_args+1; /* Alias for arg 2 */
/**********************************************************/
/* Pack the query string into the argument compund term. */
/**********************************************************/
PL_put_list_chars(swipl_goalCharList,goalString);
/**********************************************************/
/* Generate a predicate to pyrun/2 */
/**********************************************************/
swipl_predicate=PL_predicate("pyrun",2,NULL);
/**********************************************************/
/* Open the query, and iterate through the solutions. */
/**********************************************************/
swipl_qid=PL_open_query(NULL,PL_Q_NORMAL,swipl_predicate, swipl_args);
while(PL_next_solution(swipl_qid)) {
/**********************************************************/
/* Create a Python list to hold the bindings. */
/**********************************************************/
bindingList_Py=PyList_New(0);
/**********************************************************/
/* Step through the bindings and add each to the list. */
/**********************************************************/
swipl_list=PL_copy_term_ref(swipl_bindingList);
while(PL_get_list(swipl_list, swipl_head, swipl_list)) {
PL_get_chars(swipl_head, &answer, CVT_ALL|CVT_WRITE|BUF_RING);
answerString_Py = PyString_FromString(answer);
PyList_Append(bindingList_Py, answerString_Py);
Py_DECREF(answerString_Py);
}
/**********************************************************/
/* Add this binding list to the list of all solutions. */
/**********************************************************/
PyList_Append(answerList_Py, bindingList_Py);
Py_DECREF(bindingList_Py);
}
/**********************************************************/
/* Free this foreign frame... */
/* Added by Nathan Denny, July 18, 2001. */
/* Fixes a bug with running out of global stack when */
/* asserting _lots_ of facts. */
/**********************************************************/
PL_close_query(swipl_qid);
PL_discard_foreign_frame(swipl_fid);
/**********************************************************/
/* Return the list of solutions. */
/**********************************************************/
return answerList_Py;
}
}
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);
}
