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;
}
}
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;
}
cairo_bool_t
plcairo_extend_to_term(cairo_extend_t extend,
term_t t)
{
term_t t0 = PL_new_term_ref();
PLCAIRO_debug(" cairo_extend_t: %d ---> term: 0x%lx", extend, 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 ( extend == CAIRO_EXTEND_NONE )
{ PL_put_atom(t0, ATOM_cairo_extend_none);
}
else if ( extend == CAIRO_EXTEND_REPEAT )
{ PL_put_atom(t0, ATOM_cairo_extend_repeat);
}
else if ( extend == CAIRO_EXTEND_REFLECT )
{ PL_put_atom(t0, ATOM_cairo_extend_reflect);
}
else if ( extend == CAIRO_EXTEND_PAD )
{ PL_put_atom(t0, ATOM_cairo_extend_pad);
}
else
{ g_assert_not_reached();
}
return PL_unify(t, t0);
}
cairo_bool_t
plcairo_ps_level_to_term(cairo_ps_level_t level,
term_t t)
{
term_t t0 = PL_new_term_ref();
PLCAIRO_debug(" cairo_ps_level_t: %d ---> term: 0x%lx", level, 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 ( level == CAIRO_PS_LEVEL_2 )
{ PL_put_atom(t0, ATOM_cairo_ps_level_2);
}
else if ( level == CAIRO_PS_LEVEL_3 )
{ PL_put_atom(t0, ATOM_cairo_ps_level_3);
}
else
{ g_assert_not_reached();
}
return PL_unify(t, t0);
}
static foreign_t
pl_gethostname(term_t name)
{ static atom_t hname;
if ( !hname )
{ char buf[256];
if ( gethostname(buf, sizeof(buf)) == 0 )
{ struct addrinfo *res;
struct addrinfo hints;
memset(&hints, 0, sizeof(hints));
hints.ai_flags = AI_CANONNAME;
if ( getaddrinfo(buf, NULL, &hints, &res) == 0 )
{ hname = PL_new_atom(res->ai_canonname);
freeaddrinfo(res);
}
else
hname = PL_new_atom(buf);
} else
{ return nbio_error(h_errno, TCP_HERRNO);
}
}
return PL_unify_atom(name, hname);
}
static void
init_constants()
{ FUNCTOR_word1 = PL_new_functor(PL_new_atom("word"), 1);
FUNCTOR_space1 = PL_new_functor(PL_new_atom("space"), 1);
FUNCTOR_integer1 = PL_new_functor(PL_new_atom("integer"), 1);
FUNCTOR_character1= PL_new_functor(PL_new_atom("character"), 1);
FUNCTOR_newline1 = PL_new_functor(PL_new_atom("newline"), 1);
}
install_t
install_time()
{ MODULE_user = PL_new_module(PL_new_atom("user"));
FUNCTOR_alarm1 = PL_new_functor(PL_new_atom("$alarm"), 1);
FUNCTOR_alarm4 = PL_new_functor(PL_new_atom("alarm"), 4);
FUNCTOR_module2 = PL_new_functor(PL_new_atom(":"), 2);
ATOM_remove = PL_new_atom("remove");
ATOM_install = PL_new_atom("install");
ATOM_done = PL_new_atom("done");
ATOM_next = PL_new_atom("next");
ATOM_scheduled = PL_new_atom("scheduled");
PREDICATE_call1 = PL_predicate("call", 1, "user");
PL_register_foreign("alarm_at", 4, alarm4_abs, PL_FA_TRANSPARENT);
PL_register_foreign("alarm", 4, alarm4_rel, PL_FA_TRANSPARENT);
PL_register_foreign("alarm_at", 3, alarm3_abs, PL_FA_TRANSPARENT);
PL_register_foreign("alarm", 3, alarm3_rel, PL_FA_TRANSPARENT);
PL_register_foreign("remove_alarm", 1, remove_alarm, 0);
PL_register_foreign("uninstall_alarm",1, uninstall_alarm,0);
PL_register_foreign("install_alarm", 1, install_alarm, 0);
PL_register_foreign("install_alarm", 2, install_alarm2, 0);
PL_register_foreign("remove_alarm_notrace",1, remove_alarm, PL_FA_NOTRACE);
PL_register_foreign("current_alarms", 5, current_alarms, 0);
#ifdef O_DEBUG
PL_register_foreign("time_debug", 1, pl_time_debug, 0);
#endif
installHandler();
PL_on_halt(cleanup, NULL);
}
int
PL_permission_error(const char *op, const char *type, term_t obj)
{ atom_t t = PL_new_atom(type);
atom_t o = PL_new_atom(op);
int rc = PL_error(NULL, 0, NULL, ERR_PERMISSION, o, t, obj);
PL_unregister_atom(t);
PL_unregister_atom(o);
return rc;
}
static void
registerBuiltins(const PL_extension *f)
{ Module m = MODULE_system;
for(; f->predicate_name; f++)
{ Procedure proc;
atom_t name = PL_new_atom(f->predicate_name);
functor_t fdef = lookupFunctorDef(name, f->arity);
PL_unregister_atom(name);
if ( (proc = lookupProcedure(fdef, m)) )
{ Definition def = proc->definition;
set(def, P_FOREIGN|HIDE_CHILDS|P_LOCKED);
if ( f->flags & PL_FA_NOTRACE ) clear(def, TRACE_ME);
if ( f->flags & PL_FA_TRANSPARENT ) set(def, P_TRANSPARENT);
if ( f->flags & PL_FA_NONDETERMINISTIC ) set(def, P_NONDET);
if ( f->flags & PL_FA_VARARGS ) set(def, P_VARARG);
if ( f->flags & PL_FA_CREF ) set(def, P_FOREIGN_CREF);
if ( f->flags & PL_FA_ISO ) set(def, P_ISO);
def->impl.foreign.function = f->function;
createForeignSupervisor(def, f->function);
} else
{ assert(0);
}
}
}
void
PL_register_blob_type(PL_blob_t *type)
{ PL_LOCK(L_MISC); /* cannot use L_ATOM */
if ( !type->registered )
{ if ( !GD->atoms.types )
{ GD->atoms.types = type;
type->atom_name = ATOM_text; /* avoid deadlock */
type->registered = TRUE;
} else
{ PL_blob_t *t = GD->atoms.types;
while(t->next)
t = t->next;
t->next = type;
type->rank = t->rank+1;
type->registered = TRUE;
type->atom_name = PL_new_atom(type->name);
}
}
PL_UNLOCK(L_MISC);
}
void
PL_register_blob_type(PL_blob_t *type)
{ PL_LOCK(L_MISC); /* cannot use L_ATOM */
if ( !type->registered )
{ if ( !GD->atoms.types )
{ GD->atoms.types = type;
} else
{ PL_blob_t *t = GD->atoms.types;
while(t->next)
t = t->next;
t->next = type;
type->rank = t->rank+1;
}
type->registered = TRUE;
if ( !type->atom_name )
type->atom_name = PL_new_atom(type->name);
if ( true(type, PL_BLOB_TEXT) )
{ if ( true(type, PL_BLOB_WCHAR) )
type->padding = sizeof(pl_wchar_t);
else
type->padding = sizeof(char);
}
}
PL_UNLOCK(L_MISC);
}
void
PlMessage(const char *fm, ...)
{ va_list(args);
va_start(args, fm);
if ( hasConsole() )
{ Sfprintf(Serror, "SWI-Prolog: ");
Svfprintf(Serror, fm, args);
Sfprintf(Serror, "\n");
} else
{ char buf[1024];
int64_t hwndi;
HWND hwnd = NULL;
static atom_t ATOM_hwnd = 0;
if ( !ATOM_hwnd )
ATOM_hwnd = PL_new_atom("hwnd");
if ( PL_current_prolog_flag(ATOM_hwnd, PL_INTEGER, &hwndi) )
hwnd = (HWND)hwndi;
vsprintf(buf, fm, args);
MessageBox(hwnd, buf, "SWI-Prolog", MB_OK|MB_TASKMODAL);
}
va_end(args);
}
int
PL_representation_error(const char *representation)
{ atom_t r = PL_new_atom(representation);
int rc = PL_error(NULL, 0, NULL, ERR_REPRESENTATION, r);
PL_unregister_atom(r);
return rc;
}
int
init_errors(void)
{ MKFUNCTOR(error, 2);
MKFUNCTOR(literal, 1);
FUNCTOR_colon2 = PL_new_functor(PL_new_atom(":"), 2);
return TRUE;
}
int
PL_existence_error(const char *type, term_t actual)
{ atom_t a = PL_new_atom(type);
int rc = PL_error(NULL, 0, NULL, ERR_EXISTENCE, a, actual);
PL_unregister_atom(a);
return rc;
}
install_t
install_random()
{ FUNCTOR_rand3 = PL_new_functor(PL_new_atom("rand"), 3);
PL_register_foreign("random", 1, p_random, 0);
PL_register_foreign("setrand", 1, p_setrand, 0);
PL_register_foreign("getrand", 1, p_getrand, 0);
}
int
PL_domain_error(const char *expected, term_t actual)
{ atom_t a = PL_new_atom(expected);
int rc = PL_error(NULL, 0, NULL, ERR_DOMAIN, a, actual);
PL_unregister_atom(a);
return rc;
}
rb_red_blk_tree* buildEventMap()
{
printf("--- Generating Event Rule Map ... \n");
rb_red_blk_tree* EventTree = RBTreeCreate(Compare_EventType,DestroyEventType,DestroyInfoEventKey,PrintEventKey,PrintInfoEventKey);
if(!EventTree)
{
printf("Error Building the Event Rule Map.\n");
return NULL;
}
int i=0;
term_t a0 = PL_new_term_refs(3);
term_t b0 = PL_new_term_refs(2);
static predicate_t p;
static functor_t event_functor;
char myEvents[256][256];
int arity;
eventType* temp=NULL;
if ( !event_functor )
event_functor = PL_new_functor(PL_new_atom("event"), 2);
PL_cons_functor(a0+1,event_functor,b0,b0+1);
if ( !p )
p = PL_predicate("trClause", 3, NULL);
qid_t qid = PL_open_query(NULL, PL_Q_NORMAL, p, a0);
while(PL_next_solution(qid) != FALSE)
{
//termToString(b0,myEvents[i]);
atom_t name;
PL_get_name_arity(b0, &name, &arity);
sprintf(myEvents[i],"%s",PL_atom_chars(name));
temp=(eventType*)calloc(1,sizeof(eventType));
trClause* trc=(trClause*)calloc(1,sizeof(trClause));
strcpy(temp->name,PL_atom_chars(name));
temp->arity = arity;
RBTreeInsert(EventTree,temp,trc);
temp=NULL;
trc=NULL;
padding(' ',4);
printf("+New Event Signature : %s/%d\n",myEvents[i],arity);
i++;
}
PL_close_query(qid);
#if DEBUG
RBTreePrint(EventTree);
#endif
printf("--- Done!\n");
return EventTree;
}
int
PL_resource_error(const char *resource)
{ atom_t r = PL_new_atom(resource);
int rc = PL_error(NULL, 0, NULL, ERR_RESOURCE, r);
PL_unregister_atom(r);
return rc;
}
install_t
install_archive4pl(void)
{ MKATOM(close_parent);
MKATOM(compression);
MKATOM(filter);
MKATOM(format);
MKATOM(all);
MKATOM(bzip2);
MKATOM(compress);
MKATOM(gzip);
MKATOM(grzip);
MKATOM(lrzip);
MKATOM(lzip);
MKATOM(lzma);
MKATOM(lzop);
MKATOM(none);
MKATOM(rpm);
MKATOM(uu);
MKATOM(xz);
ATOM_7zip = PL_new_atom("7zip");
MKATOM(ar);
MKATOM(cab);
MKATOM(cpio);
MKATOM(empty);
MKATOM(gnutar);
MKATOM(iso9960);
MKATOM(lha);
MKATOM(mtree);
MKATOM(rar);
MKATOM(raw);
MKATOM(tar);
MKATOM(xar);
MKATOM(zip);
MKATOM(file);
MKATOM(link);
MKATOM(socket);
MKATOM(character_device);
MKATOM(block_device);
MKATOM(directory);
MKATOM(fifo);
MKFUNCTOR(error, 2);
MKFUNCTOR(archive_error, 2);
MKFUNCTOR(filetype, 1);
MKFUNCTOR(mtime, 1);
MKFUNCTOR(size, 1);
MKFUNCTOR(link_target, 1);
MKFUNCTOR(format, 1);
PL_register_foreign("archive_open_stream", 3, archive_open_stream, 0);
PL_register_foreign("archive_property", 3, archive_property, 0);
PL_register_foreign("archive_close", 1, archive_close, 0);
PL_register_foreign("archive_next_header", 2, archive_next_header, 0);
PL_register_foreign("archive_header_prop_", 2, archive_header_prop, 0);
PL_register_foreign("archive_open_entry", 2, archive_open_entry, 0);
}
install_t
install_uuid(void)
{ ATOM_version = PL_new_atom("version");
ATOM_format = PL_new_atom("format");
ATOM_atom = PL_new_atom("atom");
ATOM_integer = PL_new_atom("integer");
ATOM_dns = PL_new_atom("dns");
ATOM_url = PL_new_atom("url");
ATOM_oid = PL_new_atom("oid");
ATOM_x500 = PL_new_atom("x500");
PL_register_foreign("uuid", 2, pl_uuid, 0);
}
static foreign_t
pl_gethostname(term_t name)
{ static atom_t hname;
if ( !hname )
{ char buf[256];
if ( gethostname(buf, sizeof(buf)) == 0 )
{ struct hostent *he;
if ( (he = gethostbyname(buf)) )
hname = PL_new_atom(he->h_name);
else
hname = PL_new_atom(buf);
} else
{ return nbio_error(h_errno, TCP_HERRNO);
}
}
return PL_unify_atom(name, hname);
}
static int
dde_initialise()
{ if ( ddeInst == (DWORD)NULL )
{ if (DdeInitialize(&ddeInst, (PFNCALLBACK)DdeCallback,
APPCLASS_STANDARD|CBF_FAIL_ADVISES|CBF_FAIL_POKES|
CBF_SKIP_REGISTRATIONS|CBF_SKIP_UNREGISTRATIONS,
0L)
!= DMLERR_NO_ERROR)
{ ddeInst = (DWORD) -1;
return dde_warning("initialise");
}
MODULE_dde = lookupModule(PL_new_atom("win_dde"));
FUNCTOR_dde_connect3 =
lookupFunctorDef(PL_new_atom("$dde_connect"), 3);
FUNCTOR_dde_connect_confirm3 =
lookupFunctorDef(PL_new_atom("$dde_connect_confirm"), 3);
FUNCTOR_dde_disconnect1 =
lookupFunctorDef(PL_new_atom("$dde_disconnect"), 1);
FUNCTOR_dde_request4 =
lookupFunctorDef(PL_new_atom("$dde_request"), 4);
FUNCTOR_dde_execute3 =
lookupFunctorDef(PL_new_atom("$dde_execute"), 3);
FUNCTOR_error1 =
lookupFunctorDef(ATOM_error, 1);
}
succeed;
}
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 foreign_t
pl_get_ps_parameters(term_t file, term_t iseps, term_t bb)
{ char *fname;
FILE *fd;
if ( !PL_get_chars(file, &fname, CVT_ALL) )
return PL_warning("get_ps_parameters/3: invalid filename");
if ( (fd = fopen(fname, "r")) )
{ char buf[MAXLINE];
char *s;
if ( (s=fgets(buf, sizeof(buf), fd)) )
{ if ( substr(s, "EPSF") )
PL_unify_atom_chars(iseps, "eps");
else
PL_unify_atom_chars(iseps, "ps");
}
do
{ double a1, a2, a3, a4;
if ( sscanf(buf, "%%%%BoundingBox: %lf %lf %lf %lf", &a1, &a2, &a3, &a4) == 4 )
{ fclose(fd);
return PL_unify_term(bb,
PL_FUNCTOR, PL_new_functor(PL_new_atom("bb"), 4),
PL_FLOAT, a1,
PL_FLOAT, a2,
PL_FLOAT, a3,
PL_FLOAT, a4);
}
} while( (s=fgets(buf, sizeof(buf), fd)) );
fclose(fd);
PL_warning("get_ps_parameters/3: could not find %%%%BoundingBox in %s",
fname);
PL_fail;
}
PL_warning("get_ps_parameters/3: could not open %s", fname);
PL_fail;
}
foreign_t
pl_lowercase(term_t u, term_t l)
{ char *copy;
char *s, *q;
atom_t la;
if ( !PL_get_atom_chars(u, &s) )
return PL_warning("lowercase/2: instantiation fault");
copy = malloc(strlen(s)+1);
for( q=copy; *s; q++, s++)
*q = (isupper(*s) ? tolower(*s) : *s);
*q = '\0';
la = PL_new_atom(copy);
free(copy);
return PL_unify_atom(l, la);
}
install_t
install_turtle()
{ MKFUNCTOR(error, 2);
MKFUNCTOR(type_error, 2);
MKFUNCTOR(syntax_error, 1);
MKFUNCTOR(stream, 4);
MKFUNCTOR(representation_error, 1);
ATOM_ = PL_new_atom("");
PL_register_foreign("turtle_name_start_char",
1, turtle_name_start_char, 0);
PL_register_foreign("turtle_name", 1, turtle_name, 0);
PL_register_foreign("turtle_read_name", 4, turtle_read_name, 0);
PL_register_foreign("turtle_read_string", 4, turtle_read_string, 0);
PL_register_foreign("turtle_read_relative_uri",
4, turtle_read_relative_uri, 0);
PL_register_foreign("turtle_write_quoted_string",
2, turtle_write_quoted_string, 0);
PL_register_foreign("turtle_write_uri", 2, turtle_write_uri, 0);
}
static atom_t
tz_name_as_atom(int dst)
{ static atom_t a[2];
dst = (dst > 0); /* 0 or 1 */
if ( !a[dst] )
{ wchar_t wbuf[256];
const char *str = tz_name(dst);
size_t n;
if ( (n = mbstowcs(wbuf, str, sizeof(wbuf)/sizeof(wbuf[0])-1)) != (size_t)-1 )
{ a[dst] = PL_new_atom_wchars(n, wbuf);
} else
{ a[dst] = PL_new_atom(str);
}
}
return a[dst];
}
static int
get_showCmd(term_t show, UINT *cmd)
{ char *s;
showtype *st;
static showtype types[] =
{ { "hide", SW_HIDE },
{ "maximize", SW_MAXIMIZE },
{ "minimize", SW_MINIMIZE },
{ "restore", SW_RESTORE },
{ "show", SW_SHOW },
{ "showdefault", SW_SHOWDEFAULT },
{ "showmaximized", SW_SHOWMAXIMIZED },
{ "showminimized", SW_SHOWMINIMIZED },
{ "showminnoactive", SW_SHOWMINNOACTIVE },
{ "showna", SW_SHOWNA },
{ "shownoactive", SW_SHOWNOACTIVATE },
{ "shownormal", SW_SHOWNORMAL },
/* compatibility */
{ "normal", SW_SHOWNORMAL },
{ "iconic", SW_MINIMIZE },
{ NULL, 0 },
};
if ( show == 0 )
{ *cmd = SW_SHOWNORMAL;
succeed;
}
if ( !PL_get_chars(show, &s, CVT_ATOM|CVT_EXCEPTION) )
fail;
for(st=types; st->name; st++)
{ if ( streq(st->name, s) )
{ *cmd = st->id;
succeed;
}
}
return PL_error(NULL, 0, NULL, ERR_DOMAIN,
PL_new_atom("win_show"), show);
}
gboolean
plgi_gpointer_to_term(gpointer data,
PLGIArgInfo *arg_info,
term_t t)
{
gboolean is_owned;
PLGI_debug(" gpointer: %p ---> term: 0x%lx", data, t);
if ( !data )
{ return plgi_put_null(t);
}
is_owned = (arg_info->transfer == GI_TRANSFER_EVERYTHING) ? TRUE : FALSE;
if ( !plgi_put_blob(PLGI_BLOB_UNTYPED, G_TYPE_NONE, PL_new_atom("gpointer"),
is_owned, data, t) )
{ return FALSE;
}
return TRUE;
}
