static int
add_to_form(const char *name, size_t nlen,
const char *value, size_t len,
void *closure)
{ term_t head = PL_new_term_ref();
term_t tail = (term_t) closure;
term_t val = PL_new_term_ref();
int rc;
atom_t aname = 0;
if ( isnumber(value, len) )
{ rc = unify_number(val, value, len);
} else
{ rc = PL_unify_chars(val, PL_ATOM|REP_UTF8, len, value);
}
rc = ( rc &&
PL_unify_list(tail, head, tail) &&
(aname = PL_new_atom_nchars(nlen, name)) &&
PL_unify_term(head,
PL_FUNCTOR, PL_new_functor(aname, 1),
PL_TERM, val) );
if ( aname )
PL_unregister_atom(aname);
return rc;
}
static int
mp_add_to_form(const char *name, size_t nlen,
const char *value, size_t len,
const char *file, void *closure)
{ term_t head = PL_new_term_ref();
term_t tail = (term_t) closure;
term_t val = PL_new_term_ref();
long vl;
double vf;
int rc;
atom_t aname = 0;
if ( isinteger(value, &vl, len) )
rc = PL_put_integer(val, vl);
else if ( isfloat(value, &vf, len) )
rc = PL_put_float(val, vf);
else
rc = PL_unify_chars(val, PL_ATOM|REP_UTF8, len, value);
rc = ( rc &&
PL_unify_list(tail, head, tail) &&
(aname = PL_new_atom_nchars(nlen, name)) &&
PL_unify_term(head,
PL_FUNCTOR, PL_new_functor(aname, 1),
PL_TERM, val) );
if ( aname )
PL_unregister_atom(aname);
return rc;
}
char *
DeRefLink(const char *link, char *buf)
{ char tmp[MAXPATHLEN];
char *f;
int n = 20; /* avoid loop! */
while((f=DeRefLink1(link, tmp)) && n-- > 0)
link = f;
if ( n > 0 )
{ strcpy(buf, link);
return buf;
} else
{ GET_LD
atom_t dom = PL_new_atom("dereference");
atom_t typ = PL_new_atom("symlink");
term_t t;
int rc;
rc = ( (t=PL_new_term_ref()) &&
PL_unify_chars(t, PL_ATOM|REP_FN, -1, link) &&
PL_error(NULL, 0, "too many (>20) levels of symbolic links",
ERR_PERMISSION, dom, typ, t) );
(void)rc;
PL_unregister_atom(dom);
PL_unregister_atom(typ);
return NULL;
}
}
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
);
}
static foreign_t
snowball(term_t lang, term_t in, term_t out)
{ struct sb_stemmer *stemmer = NULL;
char *s;
size_t len, olen;
const sb_symbol *stemmed;
if ( !get_lang_stemmer(lang, &stemmer) )
return FALSE;
if ( !PL_get_nchars(in, &len, &s,
CVT_ATOM|CVT_STRING|CVT_LIST|REP_UTF8|CVT_EXCEPTION) )
return FALSE;
if ( !(stemmed = sb_stemmer_stem(stemmer, (const sb_symbol*)s, (int)len)) )
return resource_error("memory");
olen = sb_stemmer_length(stemmer);
return PL_unify_chars(out, PL_ATOM|REP_UTF8, olen, (const char*)stemmed);
}
static foreign_t
pl_no_diacritics_atom(term_t in, term_t out)
{ char *s, *to;
size_t len;
wchar_t *ws, *wto;
if (PL_get_nchars(in, &len, &s, CVT_ATOMIC))
{ if ((to = alloca(len+1)))
{ no_diacritics(s, to);
return PL_unify_chars(out, PL_ATOM, len, to);
}
} else
if (PL_get_wchars(in, &len, &ws, CVT_ATOMIC))
{ if ((wto = alloca((len+1)*sizeof(wchar_t))))
{ wno_diacritics(ws, len, wto);
return PL_unify_wchars(out, PL_ATOM, len, wto);
}
}
return FALSE;
}
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
cgi_property(term_t cgi, term_t prop)
{ IOSTREAM *s;
cgi_context *ctx;
term_t arg = PL_new_term_ref();
atom_t name;
int arity;
int rc = TRUE;
if ( !get_cgi_stream(cgi, &s, &ctx) )
return FALSE;
if ( !PL_get_name_arity(prop, &name, &arity) || arity != 1 )
{ rc = type_error(prop, "cgi_property");
goto out;
}
_PL_get_arg(1, prop, arg);
if ( name == ATOM_request )
{ if ( ctx->request )
rc = unify_record(arg, ctx->request);
else
rc = PL_unify_nil(arg);
} else if ( name == ATOM_header )
{ if ( ctx->header )
rc = unify_record(arg, ctx->header);
else
rc = PL_unify_nil(arg);
} else if ( name == ATOM_id )
{ rc = PL_unify_int64(arg, ctx->id);
} else if ( name == ATOM_client )
{ rc = PL_unify_stream(arg, ctx->stream);
} else if ( name == ATOM_transfer_encoding )
{ rc = PL_unify_atom(arg, ctx->transfer_encoding);
} else if ( name == ATOM_connection )
{ rc = PL_unify_atom(arg, ctx->connection ? ctx->connection : ATOM_close);
} else if ( name == ATOM_content_length )
{ if ( ctx->transfer_encoding == ATOM_chunked )
rc = PL_unify_int64(arg, ctx->chunked_written);
else
rc = PL_unify_int64(arg, ctx->datasize - ctx->data_offset);
} else if ( name == ATOM_header_codes )
{ if ( ctx->data_offset > 0 )
rc = PL_unify_chars(arg, PL_CODE_LIST, ctx->data_offset, ctx->data);
else /* incomplete header */
rc = PL_unify_chars(arg, PL_CODE_LIST, ctx->datasize, ctx->data);
} else if ( name == ATOM_state )
{ atom_t state;
switch(ctx->state)
{ case CGI_HDR: state = ATOM_header; break;
case CGI_DATA: state = ATOM_data; break;
case CGI_DISCARDED: state = ATOM_discarded; break;
default:
assert(0);
}
rc = PL_unify_atom(arg, state);
} else
{ rc = existence_error(prop, "cgi_property");
}
out:
if ( !PL_release_stream(s) )
{ if ( PL_exception(0) )
PL_clear_exception();
}
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 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;
}
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;
}
foreign_t
fcgi_param(term_t name, term_t value, control_t h)
{
fcgi_context *ctxt;
char **env, **cgi_environ;
char *s, *v, *sep;
ctxt = pthread_getspecific(key);
if ( FCGX_IsCGI() )
{ cgi_environ = environ;
}
else
{ cgi_environ = ctxt->env;
}
if ( !PL_is_variable(name) )
{
if ( !PL_get_atom_chars(name, &s) )
{ return PL_type_error("atom", name);
}
v = FCGX_GetParam(s, cgi_environ);
if ( !v )
{ return FALSE;
}
return PL_unify_chars(value, PL_ATOM|REP_UTF8, -1, v);
}
switch ( PL_foreign_control(h) )
{
case PL_FIRST_CALL:
{ env = cgi_environ;
break;
}
case PL_REDO:
{ env = PL_foreign_context_address(h);
break;
}
case PL_PRUNED:
default:
{ return TRUE;
}
}
for ( ; *env; env++ )
{
s = strdup(*env);
sep = index(s, '=');
sep[0] = '\0';
if ( !PL_unify_chars(name, PL_ATOM|REP_UTF8, -1, s) )
{ free(s);
return FALSE;
}
if ( !PL_unify_chars(value, PL_ATOM|REP_UTF8, -1, sep+1) )
{ free(s);
return FALSE;
}
free(s);
PL_retry_address(env+1);
}
return FALSE;
}
static int unify_value(term_t t, clingo_symbol_t v) {
// NOTE: the clingo_symbol_* functions below only fail
// if applied to the wrong type
// they do not allocate
switch (clingo_symbol_type(v)) {
case clingo_symbol_type_number: {
int number;
clingo_symbol_number(v, &number);
return PL_unify_integer(t, number);
}
case clingo_symbol_type_string: {
char const *str;
clingo_symbol_string(v, &str);
return PL_unify_chars(t, PL_STRING | REP_UTF8, (size_t)-1, str);
}
case clingo_symbol_type_infimum: {
return PL_unify_term(t, PL_FUNCTOR, FUNCTOR_hash1, PL_ATOM, ATOM_inf);
}
case clingo_symbol_type_supremum: {
return PL_unify_term(t, PL_FUNCTOR, FUNCTOR_hash1, PL_ATOM, ATOM_sup);
}
case clingo_symbol_type_function: {
// FIXME: functions can have signs represented as -f(x) in gringo
char const *str;
clingo_symbol_t const *args;
size_t size;
int rc;
clingo_symbol_name(v, &str);
clingo_symbol_arguments(v, &args, &size);
if (size == 0) {
if (!(rc =
PL_unify_chars(t, PL_ATOM | REP_UTF8, (size_t)-1, str))) {
goto out_function;
}
} else {
clingo_symbol_t const *it, *ie;
atom_t name;
term_t arg;
int i;
name = PL_new_atom(str);
if (!(rc = PL_unify_functor(t, PL_new_functor(name, size)))) {
goto out_function;
}
PL_unregister_atom(name);
arg = PL_new_term_ref();
for (i = 1, it = args, ie = it + size; it != ie; ++it, i++) {
_PL_get_arg(i, t, arg);
if (!unify_value(arg, *it)) {
goto out_function;
}
}
}
out_function:
return rc;
}
default:
assert(FALSE);
return FALSE;
}
}
