/*************************
* 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 int
domain_error(term_t actual, const char *expected)
{ term_t ex;
if ( (ex=PL_new_term_ref()) &&
PL_unify_term(ex,
PL_FUNCTOR, FUNCTOR_error2,
PL_FUNCTOR, FUNCTOR_domain_error2,
PL_CHARS, expected,
PL_TERM, actual,
PL_VARIABLE) )
return PL_raise_exception(ex);
return FALSE;
}
static int
type_error(const char *expected, term_t found)
{ term_t ex;
if ( (ex=PL_new_term_ref()) &&
PL_unify_term(ex,
PL_FUNCTOR, FUNCTOR_error2,
PL_FUNCTOR, FUNCTOR_type_error2,
PL_CHARS, expected,
PL_TERM, found,
PL_VARIABLE) )
return PL_raise_exception(ex);
return FALSE;
}
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);
}
static int
init_prolog_goal(prolog_goal *g, term_t goal, int acknowledge)
{ term_t plain = PL_new_term_ref();
g->module = NULL;
g->acknowledge = acknowledge;
g->state = G_WAITING;
if ( !PL_strip_module(goal, &g->module, plain) )
return FALSE;
if ( !(PL_is_compound(plain) || PL_is_atom(plain)) )
return type_error(goal, "callable");
g->goal = PL_record(plain);
return TRUE;
}
static int
existence_error(term_t actual, const char *type)
{ term_t ex;
if ( (ex = PL_new_term_ref()) &&
PL_unify_term(ex,
PL_FUNCTOR, FUNCTOR_error2,
PL_FUNCTOR, FUNCTOR_existence_error2,
PL_CHARS, type,
PL_TERM, actual,
PL_VARIABLE) )
return PL_raise_exception(ex);
return FALSE;
}
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;
}
/********************
* swi_list_new
********************/
term_t
swi_list_new(char **items, int n, term_t result)
{
term_t list = PL_new_term_ref();
term_t item = PL_new_term_ref();
if (n < 0) { /* NULL-terminated list, calculate items */
n = 0;
if (items)
while (items[n])
n++;
}
PL_put_nil(list);
while (n-- > 0) {
PL_put_atom_chars(item, items[n]);
PL_cons_list(list, item, list);
}
if (result && PL_is_variable(result))
PL_unify(list, result);
return list;
}
static int
permission_error(const char *op, const char *objtype, term_t obj)
{ term_t ex;
if ( (ex = PL_new_term_ref()) &&
PL_unify_term(ex,
PL_FUNCTOR, FUNCTOR_error2,
PL_FUNCTOR, FUNCTOR_permission_error3,
PL_CHARS, op,
PL_CHARS, objtype,
PL_TERM, obj,
PL_VARIABLE) )
return PL_raise_exception(ex);
return FALSE;
}
word
pl_dwim_predicate(term_t pred, term_t dwim, control_t h)
{ GET_LD
functor_t fdef;
Module module = (Module) NULL;
Procedure proc;
Symbol symb;
term_t head = PL_new_term_ref();
TableEnum e;
if ( ForeignControl(h) == FRG_CUTTED )
{ e = ForeignContextPtr(h);
freeTableEnum(e);
succeed;
}
if ( !PL_strip_module(pred, &module, head) )
fail;
if ( !PL_get_functor(head, &fdef) )
fail; /* silent: leave errors for later */
if ( ForeignControl(h) == FRG_FIRST_CALL )
e = newTableEnum(module->procedures);
else
e = ForeignContextPtr(h);
while( (symb = advanceTableEnum(e)) )
{ Definition def;
char *name;
proc = symb->value;
def = proc->definition;
name = stringAtom(def->functor->name);
if ( dwimMatch(stringAtom(nameFunctor(fdef)), name) &&
isDefinedProcedure(proc) &&
(name[0] != '$' || SYSTEM_MODE) )
{ if ( !PL_unify_functor(dwim, def->functor->functor) )
continue;
ForeignRedoPtr(e);
}
}
freeTableEnum(e);
fail;
}
static foreign_t python_export(term_t t, term_t pl) {
foreign_t rc = false;
if (PL_is_functor(t, FUNCTOR_pointer1)) {
void *ptr;
term_t targ = PL_new_term_ref();
if (!PL_get_arg(1, t, targ)) {
return false;
}
if (!PL_get_pointer(targ, &ptr)) {
return false;
}
Py_INCREF((PyObject *)ptr);
/* return __main__,s */
rc = python_to_term((PyObject *)ptr, pl);
}
return rc;
}
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';
}
// parse a list of type terms and encode as a NULL terminated
// string where each character encodes the type of one argument.
static int get_types_list(term_t list, char *typespec, int len)
{
term_t head=PL_new_term_ref();
int count=0;
// copy term ref so as not to modify original
list=PL_copy_term_ref(list);
while (PL_get_list(list,head,list) && count<len) {
atom_t name;
int arity;
const char *type;
if (!PL_get_name_arity(head,&name,&arity)) return type_error(head,"term");
type=PL_atom_chars(name);
switch (arity) {
case 1: {
if (!strcmp(type,"int")) {
typespec[count++]='i';
} else if (!strcmp(type,"double")) {
typespec[count++]='d';
} else if (!strcmp(type,"string")) {
typespec[count++]='s';
} else if (!strcmp(type,"symbol")) {
typespec[count++]='S';
} else if (!strcmp(type,"float")) {
typespec[count++]='f';
}
break;
}
case 0: {
if (!strcmp(type,"true")) typespec[count++]='T';
else if (!strcmp(type,"false")) typespec[count++]='F';
else if (!strcmp(type,"nil")) typespec[count++]='N';
else if (!strcmp(type,"inf")) typespec[count++]='I';
break;
}
}
}
typespec[count]=0;
if (!PL_get_nil(list)) return type_error(list,"nil");
return TRUE;
}
static bool
clearSourceAdmin(SourceFile sf)
{ GET_LD
int rc = FALSE;
fid_t fid = PL_open_foreign_frame();
term_t name = PL_new_term_ref();
static predicate_t pred = NULL;
if ( !pred )
pred = PL_predicate("$clear_source_admin", 1, "system");
PL_put_atom(name, sf->name);
rc = PL_call_predicate(MODULE_system, PL_Q_NORMAL, pred, name);
PL_discard_foreign_frame(fid);
return rc;
}
cairo_bool_t
plcairo_filter_to_term(cairo_filter_t filter,
term_t t)
{
term_t t0 = PL_new_term_ref();
PLCAIRO_debug(" cairo_filter_t: %d ---> term: 0x%lx", filter, 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 ( filter == CAIRO_FILTER_FAST )
{ PL_put_atom(t0, ATOM_cairo_filter_fast);
}
else if ( filter == CAIRO_FILTER_GOOD )
{ PL_put_atom(t0, ATOM_cairo_filter_good);
}
else if ( filter == CAIRO_FILTER_BEST )
{ PL_put_atom(t0, ATOM_cairo_filter_best);
}
else if ( filter == CAIRO_FILTER_NEAREST )
{ PL_put_atom(t0, ATOM_cairo_filter_nearest);
}
else if ( filter == CAIRO_FILTER_BILINEAR )
{ PL_put_atom(t0, ATOM_cairo_filter_bilinear);
}
else if ( filter == CAIRO_FILTER_GAUSSIAN )
{ PL_put_atom(t0, ATOM_cairo_filter_gaussian);
}
else
{ g_assert_not_reached();
}
return PL_unify(t, t0);
}
cairo_bool_t
plcairo_pattern_type_to_term(cairo_pattern_type_t pattern_type,
term_t t)
{
term_t t0 = PL_new_term_ref();
PLCAIRO_debug(" cairo_pattern_type_t: %d ---> term: 0x%lx", pattern_type, 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 ( pattern_type == CAIRO_PATTERN_TYPE_SOLID )
{ PL_put_atom(t0, ATOM_cairo_pattern_type_solid);
}
else if ( pattern_type == CAIRO_PATTERN_TYPE_SURFACE )
{ PL_put_atom(t0, ATOM_cairo_pattern_type_surface);
}
else if ( pattern_type == CAIRO_PATTERN_TYPE_LINEAR )
{ PL_put_atom(t0, ATOM_cairo_pattern_type_linear);
}
else if ( pattern_type == CAIRO_PATTERN_TYPE_RADIAL )
{ PL_put_atom(t0, ATOM_cairo_pattern_type_radial);
}
else if ( pattern_type == CAIRO_PATTERN_TYPE_MESH )
{ PL_put_atom(t0, ATOM_cairo_pattern_type_mesh);
}
else if ( pattern_type == CAIRO_PATTERN_TYPE_RASTER_SOURCE )
{ PL_put_atom(t0, ATOM_cairo_pattern_type_raster_source);
}
else
{ g_assert_not_reached();
}
return PL_unify(t, t0);
}
static int
get_exe(term_t exe, p_options *info)
{ int arity;
term_t arg = PL_new_term_ref();
if ( !PL_get_name_arity(exe, &info->exe_name, &arity) )
return type_error(exe, "callable");
PL_put_atom(arg, info->exe_name);
#ifdef __WINDOWS__
if ( !PL_get_wchars(arg, NULL, &info->exe, CVT_ATOM|CVT_EXCEPTION|BUF_MALLOC) )
return FALSE;
if ( !win_command_line(exe, arity, info->exe, &info->cmdline) )
return FALSE;
#else /*__WINDOWS__*/
if ( !PL_get_chars(arg, &info->exe, CVT_ATOM|CVT_EXCEPTION|BUF_MALLOC|REP_FN) )
return FALSE;
if ( !(info->argv = PL_malloc((arity+2)*sizeof(char*))) )
return PL_resource_error("memory");
memset(info->argv, 0, (arity+2)*sizeof(char*));
if ( !(info->argv[0] = PL_malloc(strlen(info->exe)+1)) )
return PL_resource_error("memory");
strcpy(info->argv[0], info->exe);
{ int i;
for(i=1; i<=arity; i++)
{ _PL_get_arg(i, exe, arg);
if ( !PL_get_chars(arg, &info->argv[i],
CVT_ATOMIC|CVT_EXCEPTION|BUF_MALLOC|REP_FN) )
return FALSE;
}
info->argv[i] = NULL;
}
#endif /*__WINDOWS__*/
return TRUE;
}
static int
win_exec(size_t len, const wchar_t *cmd, UINT show)
{ GET_LD
STARTUPINFOW startup;
PROCESS_INFORMATION info;
int rval;
wchar_t *wcmd;
memset(&startup, 0, sizeof(startup));
startup.cb = sizeof(startup);
startup.wShowWindow = show;
/* ensure 0-terminated */
wcmd = PL_malloc((len+1)*sizeof(wchar_t));
memcpy(wcmd, cmd, len*sizeof(wchar_t));
wcmd[len] = 0;
rval = CreateProcessW(NULL, /* app */
wcmd,
NULL, NULL, /* security */
FALSE, /* inherit handles */
0, /* flags */
NULL, /* environment */
NULL, /* Directory */
&startup,
&info); /* process info */
PL_free(wcmd);
if ( rval )
{ CloseHandle(info.hProcess);
CloseHandle(info.hThread);
succeed;
} else
{ term_t tmp = PL_new_term_ref();
return ( PL_unify_wchars(tmp, PL_ATOM, len, cmd) &&
PL_error(NULL, 0, WinError(), ERR_SHELL_FAILED, tmp)
);
}
}
tcp_get_socket(term_t Socket, int *id)
{ IOSTREAM *s;
int socket;
if ( PL_is_functor(Socket, FUNCTOR_socket1) )
{ term_t a = PL_new_term_ref();
_PL_get_arg(1, Socket, a);
if ( PL_get_integer(a, id) )
return TRUE;
}
if ( PL_get_stream_handle(Socket, &s) )
{ socket = (int)(intptr_t)s->handle;
*id = socket;
return TRUE;
}
return pl_error(NULL, 0, NULL, ERR_ARGTYPE, -1, Socket, "socket");
}
static int
archive_error(archive_wrapper *ar)
{ int eno = archive_errno(ar->archive);
if ( eno != 0 )
{ const char *s = archive_error_string(ar->archive);
term_t ex = PL_new_term_ref();
if ( PL_unify_term(ex,
PL_FUNCTOR, FUNCTOR_error2,
PL_FUNCTOR, FUNCTOR_archive_error2,
PL_INT, errno,
PL_CHARS, s,
PL_VARIABLE) )
return PL_raise_exception(ex);
return FALSE;
}
return TRUE;
}
static int
zunlock(zipper *z)
{ int tid = PL_thread_self();
if ( z->owner == tid )
{ if ( z->lock_count == 0 )
{ term_t t;
error:
{ GET_LD
return ( (t=PL_new_term_ref()) &&
unify_zipper(t, z) &&
PL_permission_error("unlock", "zipper", t)
);
}
}
if ( --z->lock_count == 0 )
{ z->owner = 0;
simpleMutexUnlock(&z->lock);
}
} else
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);
}
}
void initpyswipl() {
char *plargs[3];
term_t swipl_load;
fid_t swipl_fid;
/**********************************************************/
/* Initialize the prolog kernel. */
/* The kernel is embedded (linked in) so I am setting the */
/* the startup path to be the current directory. Also, */
/* I'm sending the -q flag to supress the startup banner. */
/**********************************************************/
plargs[0]="./";
plargs[1]="-q";
plargs[2]="-nosignals";
PL_initialise(3,plargs);
/**********************************************************/
/* Load the pyrun predicate. */
/* The pyrun.pl file has to be in the current working */
/* directory. */
/**********************************************************/
swipl_fid=PL_open_foreign_frame();
swipl_load=PL_new_term_ref();
/**********************************************************/
/* Changed by Nathan Denny July 18, 2001 */
/* No longer necessary to include pyrun.pl */
/**********************************************************/
/*PL_chars_to_term("consult('pyrun.pl')", swipl_load);*/
PL_chars_to_term("assert(pyrun(GoalString,BindingList):-(atom_codes(A,GoalString),atom_to_term(A,Goal,BindingList),call(Goal))).", swipl_load);
PL_call(swipl_load,NULL);
PL_discard_foreign_frame(swipl_fid);
/**********************************************************/
/* Call the Python module initializer. */
/**********************************************************/
(void) Py_InitModule("pyswipl",pyswiplMethods);
}
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 int
win_wait_success(atom_t exe, HANDLE process)
{ ULONG rc;
if ( !wait_process_handle(process, &rc, INFINITE) )
return FALSE;
if ( rc != 0 )
{ term_t ex = PL_new_term_ref();
if ( PL_unify_term(ex,
PL_FUNCTOR, FUNCTOR_error2,
PL_FUNCTOR, FUNCTOR_process_error2,
PL_ATOM, exe,
PL_FUNCTOR, FUNCTOR_exit1,
PL_LONG, rc,
PL_VARIABLE) )
return PL_raise_exception(ex);
return FALSE;
}
return TRUE;
}
static int
get_timer(term_t t, Event *ev)
{ if ( PL_is_functor(t, FUNCTOR_alarm1) )
{ term_t a = PL_new_term_ref();
void *p;
_PL_get_arg(1, t, a);
if ( PL_get_pointer(a, &p) )
{ Event e = p;
if ( e->magic == EV_MAGIC )
{ *ev = e;
return TRUE;
} else
{ return pl_error("get_timer", 1, NULL,
ERR_DOMAIN, t, "alarm");
}
}
}
return pl_error("get_timer", 1, NULL,
ERR_ARGTYPE, 1, t, "alarm");
}
static void
rewrite_callable(atom_t *expected, term_t actual)
{ GET_LD
term_t a = 0;
int loops = 0;
while ( PL_is_functor(actual, FUNCTOR_colon2) )
{ if ( !a )
a = PL_new_term_ref();
_PL_get_arg(1, actual, a);
if ( !PL_is_atom(a) )
{ *expected = ATOM_atom;
PL_put_term(actual, a);
return;
} else
{ _PL_get_arg(2, actual, a);
PL_put_term(actual, a);
}
if ( ++loops > 100 && !PL_is_acyclic(actual) )
break;
}
}
cairo_bool_t
plcairo_pattern_to_term(cairo_pattern_t *pattern,
term_t t)
{
PLGIBlobType blob_type;
gpointer data;
term_t t0 = PL_new_term_ref();
PLCAIRO_debug(" cairo_pattern_t: %p ---> term: 0x%lx", pattern, t);
if ( !pattern )
{ return ( plgi_put_null(t0) && PL_unify(t, t0) );
}
data = pattern;
blob_type = PLGI_BLOB_BOXED;
if ( !plgi_put_blob(blob_type, CAIRO_GOBJECT_TYPE_PATTERN,
PL_new_atom("CairoPattern"), TRUE, data, t0) )
{ return FALSE;
}
return PL_unify(t, t0);;
}
static HANDLE
find_process_from_pid(DWORD pid, const char *pred)
{ win_process *wp;
LOCK();
for(wp=processes; wp; wp=wp->next)
{ if ( wp->pid == pid )
{ HANDLE h = wp->handle;
UNLOCK();
return h;
}
}
UNLOCK();
if ( pred )
{ term_t ex = PL_new_term_ref();
if ( PL_put_integer(ex, pid) )
PL_existence_error("process", ex);
}
return (HANDLE)0;
}
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;
}
}
