gboolean
plgi_term_to_gpointer(term_t t,
PLGIArgInfo *arg_info,
gpointer *data)
{
PLGIBlob *blob;
PLGI_debug(" term: 0x%lx ---> gpointer: %p", t, *data);
if ( !plgi_get_blob(t, &blob) )
{ return PL_type_error("gpointer", t);
}
if ( blob->gtype != G_TYPE_NONE )
{ return PL_type_error("gpointer", t);
}
if ( arg_info->flags & PLGI_ARG_IS_POINTER )
{ *data = blob->data;
}
else
{ plgi_raise_error("cannot pass-by-value untyped gpointer");
return FALSE;
}
if ( arg_info->direction == GI_DIRECTION_IN &&
arg_info->transfer != GI_TRANSFER_NOTHING )
{ blob->magic = 0x0;
}
return TRUE;
}
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 int get_params(term_t t, clingo_part_t *pv) {
int rc;
atom_t name;
term_t arg;
clingo_symbol_t *values = NULL;
if (!(rc = get_name_arity(t, &name, &pv->size))) {
rc = PL_type_error("callable", t);
goto out;
}
arg = PL_new_term_ref();
if (!(values = malloc(sizeof(*pv->params) * pv->size))) {
rc = PL_resource_error("memory");
goto out;
}
for (size_t i = 0; i < pv->size; i++) {
_PL_get_arg(i + 1, t, arg);
if (!(rc = clingo_status(get_value(arg, &values[i], FALSE)))) {
goto out;
}
}
pv->params = values;
pv->name = PL_atom_chars(name);
values = NULL;
out:
if (values) {
free(values);
}
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 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
);
}
/* cairo_pattern_t */
cairo_bool_t
plcairo_term_to_pattern(term_t t,
cairo_pattern_t **pattern)
{
PLGIBlob *blob;
PLCAIRO_debug(" term: 0x%lx ---> cairo_pattern_t: %p", t, *pattern);
if ( !plgi_get_blob(t, &blob) )
{ return PL_type_error("CairoPattern", t);
}
if ( blob->gtype != G_TYPE_NONE &&
!g_type_is_a( blob->gtype, CAIRO_GOBJECT_TYPE_PATTERN ) )
{ return PL_type_error("CairoPattern", t);
}
*pattern = blob->data;
return TRUE;
}
static foreign_t
p_setrand(term_t state)
{ if ( !PL_is_functor(state, FUNCTOR_rand3) )
return PL_type_error("rand_state", state);
if ( !get_short_arg_ex(1, state, &a1) ||
!get_short_arg_ex(2, state, &b1) ||
!get_short_arg_ex(3, state, &c1) )
return FALSE;
return TRUE;
}
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_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 pl_clingo_add(term_t ccontrol, term_t params, term_t program) {
char *prog;
clingo_env *ctl;
atom_t name;
size_t arity;
char *param_buf[FAST_PARAMS];
char **prog_params = param_buf;
term_t arg = PL_new_term_ref();
int rc;
if (!(rc = get_clingo(ccontrol, &ctl))) {
goto out;
}
if (!get_name_arity(params, &name, &arity)) {
rc = PL_type_error("callable", params);
goto out;
}
if (arity + 1 > FAST_PARAMS &&
!(prog_params = malloc(sizeof(char *) * arity))) {
rc = PL_resource_error("memory");
goto out;
}
for (size_t i = 0; i < arity; i++) {
_PL_get_arg(i + 1, params, arg);
if (!(rc =
get_null_terminated_string(arg, &prog_params[i], CVT_ATOM))) {
goto out;
}
}
if (!(rc = get_null_terminated_string(program, &prog,
CVT_ATOM | CVT_STRING | CVT_LIST |
BUF_DISCARDABLE))) {
goto out;
}
if (!(rc = clingo_status(
clingo_control_add(ctl->control, PL_atom_chars(name),
(const char **)prog_params, arity, prog)))) {
goto out;
}
out:
if (prog_params != param_buf) {
free(prog_params);
}
return rc;
}
static foreign_t
pl_user_info(term_t user, term_t info)
{ int uid;
struct passwd pwd, *pwdp;
char buf[1000];
char *name;
if ( PL_get_integer(user, &uid) )
{ again1:
errno = 0;
if ( getpwuid_r(uid, &pwd, buf, sizeof(buf), &pwdp) != 0 )
{ if ( errno == EINTR )
{ if ( PL_handle_signals() < 0 )
return FALSE;
goto again1;
}
return error(errno, "info", "user", user);
}
} else if ( PL_get_chars(user, &name, CVT_ATOMIC|REP_MB) )
{ again2:
errno = 0;
if ( getpwnam_r(name, &pwd, buf, sizeof(buf), &pwdp) != 0 )
{ if ( errno == EINTR )
{ if ( PL_handle_signals() < 0 )
return FALSE;
goto again2;
}
return error(errno, "info", "user", user);
}
} else
{ return PL_type_error("user", user);
}
if ( !pwdp )
return PL_existence_error("user", user);
return PL_unify_term(info,
PL_FUNCTOR_CHARS, "user_info", 7,
PL_MBCHARS, pwdp->pw_name,
PL_MBCHARS, pwdp->pw_passwd,
PL_INT, (int)pwdp->pw_uid,
PL_INT, (int)pwdp->pw_gid,
PL_MBCHARS, pwdp->pw_gecos,
PL_MBCHARS, pwdp->pw_dir,
PL_MBCHARS, pwdp->pw_shell
);
}
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 int get_clingo(term_t t, clingo_env **ccontrol) {
PL_blob_t *type;
void *data;
if (PL_get_blob(t, &data, NULL, &type) && type == &clingo_blob) {
clingo_wrapper *ar = data;
assert(ar->magic == CLINGO_MAGIC);
if (!ar->clingo->control) {
return PL_existence_error("clingo", t);
}
*ccontrol = ar->clingo;
return TRUE;
}
return PL_type_error("clingo", t);
}
static int
get_dict_ex(term_t t, Word dp, int ex ARG_LD)
{ Word p = valTermRef(t);
deRef(p);
if ( isTerm(*p) )
{ Functor f = valueTerm(*p);
FunctorDef fd = valueFunctor(f->definition);
if ( fd->name == ATOM_dict &&
fd->arity%2 == 1 ) /* does *not* validate ordering */
{ *dp = *p;
return TRUE;
}
}
if ( !ex )
return FALSE;
PL_type_error("dict", t);
return FALSE;
}
static int
get_archive(term_t t, archive_wrapper **arp)
{ PL_blob_t *type;
void *data;
if ( PL_get_blob(t, &data, NULL, &type) && type == &archive_blob)
{ archive_wrapper *ar = data;
assert(ar->magic == ARCHIVE_MAGIC);
if ( ar->symbol )
{ *arp = ar;
return TRUE;
}
PL_permission_error("access", "closed_archive", t);
return FALSE;
}
return PL_type_error("archive", t);
}
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_create_dict_ex(term_t t, term_t dt ARG_LD)
{ Word p = valTermRef(t);
deRef(p);
if ( isTerm(*p) )
{ Functor f = valueTerm(*p);
FunctorDef fd = valueFunctor(f->definition);
if ( fd->name == ATOM_dict &&
fd->arity%2 == 1 ) /* does *not* validate ordering */
{ *valTermRef(dt) = *p;
return TRUE;
}
}
if ( PL_get_dict_ex(t, 0, dt, DICT_GET_ALL) )
{ assert(isTerm(*valTermRef(dt)));
return TRUE;
}
return PL_type_error("dict", t);
}
static foreign_t pl_clingo_solve(term_t ccontrol, term_t assumptions,
term_t Show, term_t Model, control_t h) {
int rc = TRUE;
solve_state *state = NULL;
clingo_symbolic_literal_t *assump_vec = NULL;
int control = PL_foreign_control(h);
if (control == PL_FIRST_CALL) {
size_t alen = 0;
if (!(state = malloc(sizeof(*state)))) {
rc = PL_resource_error("memory");
goto out;
}
memset(state, 0, sizeof(*state));
if (!(rc = get_clingo(ccontrol, &state->ctl))) {
goto out;
}
if (PL_skip_list(assumptions, 0, &alen) != PL_LIST) {
rc = PL_type_error("list", assumptions);
goto out;
}
term_t tail = PL_copy_term_ref(assumptions);
term_t head = PL_new_term_ref();
if (!(assump_vec = malloc(sizeof(*assump_vec) * alen))) {
rc = PL_resource_error("memory");
goto out;
}
memset(assump_vec, 0, sizeof(*assump_vec) * alen);
for (size_t i = 0; PL_get_list(tail, head, tail); i++) {
if (!(rc = clingo_status(get_assumption(head, &assump_vec[i])))) {
goto out;
}
}
if (!(rc = clingo_status(clingo_control_solve_iteratively(
state->ctl->control, assump_vec, alen, &state->it)))) {
goto out;
}
} else {
state = PL_foreign_context_address(h);
}
while (control != PL_PRUNED) {
clingo_model_t *model;
if (!(rc = clingo_status(
clingo_solve_iteratively_next(state->it, &model)))) {
goto out;
}
if (model) {
int show;
if (!(rc = get_show_map(Show, &show))) {
goto out;
}
if (!(rc = unify_model(Model, show, model))) {
if (PL_exception(0)) {
goto out;
}
} else {
PL_retry_address(state);
state = NULL;
break;
}
} else {
rc = FALSE;
break;
}
}
out:
if (assump_vec) {
free(assump_vec);
}
if (state) {
if (state->it) {
clingo_solve_iteratively_close(state->it);
}
free(state);
}
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 foreign_t
archive_open_stream(term_t data, term_t handle, term_t options)
{ IOSTREAM *datas;
archive_wrapper *ar;
term_t tail = PL_copy_term_ref(options);
term_t head = PL_new_term_ref();
term_t arg = PL_new_term_ref();
if ( !PL_get_stream_handle(data, &datas) )
return FALSE;
if ( !(datas->flags & SIO_INPUT) )
{ PL_release_stream(datas);
return PL_domain_error("input_stream", data);
}
ar = PL_malloc(sizeof(*ar));
memset(ar, 0, sizeof(*ar));
ar->data = datas;
ar->magic = ARCHIVE_MAGIC;
if ( !PL_unify_blob(handle, ar, sizeof(*ar), &archive_blob) )
return FALSE;
while( PL_get_list_ex(tail, head, tail) )
{ atom_t name;
int arity;
if ( !PL_get_name_arity(head, &name, &arity) ||
!PL_get_arg(1, head, arg) )
return PL_type_error("option", head);
if ( name == ATOM_compression || name == ATOM_filter )
{ atom_t c;
if ( !PL_get_atom_ex(arg, &c) )
return FALSE;
if ( c == ATOM_all )
ar->type |= FILTER_ALL;
#ifdef FILTER_BZIP2
else if ( c == ATOM_bzip2 )
ar->type |= FILTER_BZIP2;
#endif
#ifdef FILTER_COMPRESS
else if ( c == ATOM_compress )
ar->type |= FILTER_COMPRESS;
#endif
#ifdef FILTER_GZIP
else if ( c == ATOM_gzip )
ar->type |= FILTER_GZIP;
#endif
#ifdef FILTER_GRZIP
else if ( c == ATOM_grzip )
ar->type |= FILTER_GRZIP;
#endif
#ifdef FILTER_LRZIP
else if ( c == ATOM_lrzip )
ar->type |= FILTER_LRZIP;
#endif
#ifdef FILTER_LZIP
else if ( c == ATOM_lzip )
ar->type |= FILTER_LZIP;
#endif
#ifdef FILTER_LZMA
else if ( c == ATOM_lzma )
ar->type |= FILTER_LZMA;
#endif
#ifdef FILTER_LZOP
else if ( c == ATOM_lzop )
ar->type |= FILTER_LZOP;
#endif
#ifdef FILTER_NONE
else if ( c == ATOM_none )
ar->type |= FILTER_NONE;
#endif
#ifdef FILTER_RPM
else if ( c == ATOM_rpm )
ar->type |= FILTER_RPM;
#endif
#ifdef FILTER_UU
else if ( c == ATOM_uu )
ar->type |= FILTER_UU;
#endif
#ifdef FILTER_XZ
else if ( c == ATOM_xz )
ar->type |= FILTER_XZ;
#endif
else
return PL_domain_error("filter", arg);
} else if ( name == ATOM_format )
{ atom_t f;
if ( !PL_get_atom_ex(arg, &f) )
return FALSE;
if ( f == ATOM_all )
ar->type |= FORMAT_ALL;
#ifdef FORMAT_7ZIP
else if ( f == ATOM_7zip )
ar->type |= FORMAT_7ZIP;
#endif
#ifdef FORMAT_AR
else if ( f == ATOM_ar )
ar->type |= FORMAT_AR;
#endif
#ifdef FORMAT_CAB
else if ( f == ATOM_cab )
ar->type |= FORMAT_CAB;
#endif
#ifdef FORMAT_CPIO
else if ( f == ATOM_cpio )
ar->type |= FORMAT_CPIO;
#endif
#ifdef FORMAT_EMPTY
else if ( f == ATOM_empty )
ar->type |= FORMAT_EMPTY;
#endif
#ifdef FORMAT_GNUTAR
else if ( f == ATOM_gnutar )
ar->type |= FORMAT_GNUTAR;
#endif
#ifdef FORMAT_ISO9960
else if ( f == ATOM_iso9960 )
ar->type |= FORMAT_ISO9960;
#endif
#ifdef FORMAT_LHA
else if ( f == ATOM_lha )
ar->type |= FORMAT_LHA;
#endif
#ifdef FORMAT_MTREE
else if ( f == ATOM_mtree )
ar->type |= FORMAT_MTREE;
#endif
#ifdef FORMAT_RAR
else if ( f == ATOM_rar )
ar->type |= FORMAT_RAR;
#endif
#ifdef FORMAT_RAW
else if ( f == ATOM_raw )
ar->type |= FORMAT_RAW;
#endif
#ifdef FORMAT_TAR
else if ( f == ATOM_tar )
ar->type |= FORMAT_TAR;
#endif
#ifdef FORMAT_XAR
else if ( f == ATOM_xar )
ar->type |= FORMAT_XAR;
#endif
#ifdef FORMAT_ZIP
else if ( f == ATOM_zip )
ar->type |= FORMAT_ZIP;
#endif
else
return PL_domain_error("format", arg);
} else if ( name == ATOM_close_parent )
{ if ( !PL_get_bool_ex(arg, &ar->close_parent) )
return FALSE;
}
}
if ( !PL_get_nil_ex(tail) )
return FALSE;
if ( !(ar->type & FILTER_ALL) )
ar->type |= FILTER_ALL;
if ( !(ar->type & FORMAT_MASK) )
ar->type |= FORMAT_ALL;
if ( !(ar->archive = archive_read_new()) )
return PL_resource_error("memory");
if ( (ar->type & FILTER_ALL) == FILTER_ALL )
{ archive_read_support_filter_all(ar->archive);
} else
{
#ifdef FILTER_BZIP2
enable_type(ar, FILTER_BZIP2, archive_read_support_filter_bzip2);
#endif
#ifdef FILTER_COMPRESS
enable_type(ar, FILTER_COMPRESS, archive_read_support_filter_compress);
#endif
#ifdef FILTER_GZIP
enable_type(ar, FILTER_GZIP, archive_read_support_filter_gzip);
#endif
#ifdef FILTER_GRZIP
enable_type(ar, FILTER_GRZIP, archive_read_support_filter_grzip);
#endif
#ifdef FILTER_LRZIP
enable_type(ar, FILTER_LRZIP, archive_read_support_filter_lrzip);
#endif
#ifdef FILTER_LZIP
enable_type(ar, FILTER_LZIP, archive_read_support_filter_lzip);
#endif
#ifdef FILTER_LZMA
enable_type(ar, FILTER_LZMA, archive_read_support_filter_lzma);
#endif
#ifdef FILTER_LZOP
enable_type(ar, FILTER_LZOP, archive_read_support_filter_lzop);
#endif
#ifdef FILTER_NONE
enable_type(ar, FILTER_NONE, archive_read_support_filter_none);
#endif
#ifdef FILTER_RPM
enable_type(ar, FILTER_RPM, archive_read_support_filter_rpm);
#endif
#ifdef FILTER_UU
enable_type(ar, FILTER_UU, archive_read_support_filter_uu);
#endif
#ifdef FILTER_XZ
enable_type(ar, FILTER_XZ, archive_read_support_filter_xz);
#endif
}
if ( (ar->type & FORMAT_ALL) == FORMAT_ALL )
{ archive_read_support_format_all(ar->archive);
#ifdef FORMAT_RAW
enable_type(ar, FORMAT_RAW, archive_read_support_format_raw);
#endif
} else
{
#ifdef FORMAT_7ZIP
enable_type(ar, FORMAT_7ZIP, archive_read_support_format_7zip);
#endif
#ifdef FORMAT_AR
enable_type(ar, FORMAT_AR, archive_read_support_format_ar);
#endif
#ifdef FORMAT_CAB
enable_type(ar, FORMAT_CAB, archive_read_support_format_cab);
#endif
#ifdef FORMAT_CPIO
enable_type(ar, FORMAT_CPIO, archive_read_support_format_cpio);
#endif
#ifdef FORMAT_EMPTY
enable_type(ar, FORMAT_EMPTY, archive_read_support_format_empty);
#endif
#ifdef FORMAT_GNUTAR
enable_type(ar, FORMAT_GNUTAR, archive_read_support_format_gnutar);
#endif
#ifdef FORMAT_ISO9960
enable_type(ar, FORMAT_ISO9960, archive_read_support_format_iso9660);
#endif
#ifdef FORMAT_LHA
enable_type(ar, FORMAT_LHA, archive_read_support_format_lha);
#endif
#ifdef FORMAT_MTREE
enable_type(ar, FORMAT_MTREE, archive_read_support_format_mtree);
#endif
#ifdef FORMAT_RAR
enable_type(ar, FORMAT_RAR, archive_read_support_format_rar);
#endif
#ifdef FORMAT_RAW
enable_type(ar, FORMAT_RAW, archive_read_support_format_raw);
#endif
#ifdef FORMAT_TAR
enable_type(ar, FORMAT_TAR, archive_read_support_format_tar);
#endif
#ifdef FORMAT_XAR
enable_type(ar, FORMAT_XAR, archive_read_support_format_xar);
#endif
#ifdef FORMAT_ZIP
enable_type(ar, FORMAT_ZIP, archive_read_support_format_zip);
#endif
}
#ifdef HAVE_ARCHIVE_READ_OPEN1
archive_read_set_callback_data(ar->archive, ar);
archive_read_set_open_callback(ar->archive, ar_open);
archive_read_set_read_callback(ar->archive, ar_read);
archive_read_set_skip_callback(ar->archive, ar_skip);
archive_read_set_seek_callback(ar->archive, ar_seek);
archive_read_set_close_callback(ar->archive, ar_close);
if ( archive_read_open1(ar->archive) == ARCHIVE_OK )
{ ar->status = AR_OPENED;
return TRUE;
}
#else
if ( archive_read_open2(ar->archive, ar,
ar_open, ar_read, ar_skip, ar_close) == ARCHIVE_OK )
{ ar->status = AR_OPENED;
return TRUE;
}
#endif
return archive_error(ar);
}
static foreign_t
archive_header_prop(term_t archive, term_t field)
{ archive_wrapper *ar;
functor_t prop;
if ( !get_archive(archive, &ar) )
return FALSE;
if ( !PL_get_functor(field, &prop) )
return PL_type_error("compound", field);
if ( ar->status != AR_NEW_ENTRY )
return PL_permission_error("access", "archive_entry", archive);
if ( prop == FUNCTOR_filetype1 )
{ __LA_MODE_T type = archive_entry_filetype(ar->entry);
atom_t name;
term_t arg = PL_new_term_ref();
_PL_get_arg(1, field, arg);
switch(type&AE_IFMT)
{ case AE_IFREG: name = ATOM_file; break;
case AE_IFLNK: name = ATOM_link; break;
case AE_IFSOCK: name = ATOM_socket; break;
case AE_IFCHR: name = ATOM_character_device; break;
case AE_IFBLK: name = ATOM_block_device; break;
case AE_IFDIR: name = ATOM_directory; break;
case AE_IFIFO: name = ATOM_fifo; break;
default:
return PL_unify_integer(arg, (type&AE_IFMT));
}
return PL_unify_atom(arg, name);
} else if ( prop == FUNCTOR_mtime1 )
{ time_t stamp = archive_entry_mtime(ar->entry);
term_t arg = PL_new_term_ref();
_PL_get_arg(1, field, arg);
return PL_unify_float(arg, (double)stamp);
} else if ( prop == FUNCTOR_size1 )
{ int64_t size = archive_entry_size(ar->entry);
term_t arg = PL_new_term_ref();
_PL_get_arg(1, field, arg);
return PL_unify_int64(arg, size);
} else if ( prop == FUNCTOR_link_target1 )
{ __LA_MODE_T type = archive_entry_filetype(ar->entry);
const wchar_t *target = NULL;
switch(type&AE_IFMT)
{ case AE_IFLNK:
target = archive_entry_symlink_w(ar->entry);
break;
}
if ( target )
{ term_t arg = PL_new_term_ref();
_PL_get_arg(1, field, arg);
return PL_unify_wchars(arg, PL_ATOM, (size_t)-1, target);
}
return FALSE;
} else if ( prop == FUNCTOR_format1 )
{ const char *s = archive_format_name(ar->archive);
if ( s )
{ char lwr[50];
char *o;
term_t arg = PL_new_term_ref();
_PL_get_arg(1, field, arg);
for(o=lwr; *s && o < lwr+sizeof(lwr); )
*o++ = tolower(*s++);
*o = '\0';
return PL_unify_atom_chars(arg, lwr);
}
}
return PL_domain_error("archive_header_property", field);
}
