word
pl_dde_poke(term_t handle, term_t item, term_t data, term_t timeout)
{ int hdl;
char *datastr;
HDDEDATA Hvalue;
HSZ Hitem;
long tmo;
if ( !get_conv_handle(handle, &hdl) ||
!get_hsz(item, &Hitem) )
fail;
if ( !PL_get_chars(data, &datastr, CVT_ALL) )
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_text, data);
if ( !PL_get_long(timeout, &tmo) )
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_integer, timeout);
if ( tmo <= 0 )
tmo = TIMEOUT_VERY_LONG;
Hvalue = DdeClientTransaction(datastr, strlen(datastr)+1,
conv_handle[hdl], Hitem, CF_TEXT,
XTYP_POKE, (DWORD)tmo, NULL);
if ( !Hvalue )
return dde_warning("poke");
succeed;
}
static int
win_shell(term_t op, term_t file, term_t how)
{ size_t lo, lf;
wchar_t *o, *f;
UINT h;
HINSTANCE instance;
if ( !PL_get_wchars(op, &lo, &o, CVT_ALL|CVT_EXCEPTION|BUF_RING) ||
!PL_get_wchars(file, &lf, &f, CVT_ALL|CVT_EXCEPTION|BUF_RING) ||
!get_showCmd(how, &h) )
fail;
instance = ShellExecuteW(NULL, o, f, NULL, NULL, h);
if ( (intptr_t)instance <= 32 )
{ const shell_error *se;
for(se = se_errors; se->message; se++)
{ if ( se->eno == (int)(intptr_t)instance )
return PL_error(NULL, 0, se->message, ERR_SHELL_FAILED, file);
}
PL_error(NULL, 0, NULL, ERR_SHELL_FAILED, file);
}
succeed;
}
static int
get_conv_handle(term_t handle, int *theh)
{ int h;
if ( !PL_get_integer(handle, &h) || h < 0 || h >= MAX_CONVERSATIONS )
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_dde_handle, handle);
if ( !conv_handle[h] )
return PL_error(NULL, 0, 0, ERR_EXISTENCE, ATOM_dde_handle, handle);
*theh = h;
succeed;
}
void *
PL_get_dbref(term_t t, db_ref_type *type_ptr)
{ void *data;
PL_blob_t *type;
if ( !PL_get_blob(t, &data, NULL, &type) )
{ error:
PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_db_reference, t);
return NULL;
}
if ( type == &clause_blob )
{ clref *ref = data;
if ( false(ref->clause, CL_ERASED) )
{ *type_ptr = DB_REF_CLAUSE;
return ref->clause;
}
} else if ( type == &record_blob )
{ recref *ref = data;
if ( ref->record->record &&
false(ref->record->record, R_ERASED) )
{ *type_ptr = DB_REF_RECORD;
return ref->record;
}
} else
{ goto error;
}
return NULL;
}
static int
dict_ordered(Word data, int count, int ex ARG_LD)
{ int ordered = TRUE;
Word n1, n2;
if ( count > 0 )
{ data++; /* skip to key */
deRef2(data, n1);
if ( !is_key(*n1) )
return -1;
}
for(; count > 1; count--, data += 2, n1=n2)
{ deRef2(data+2, n2);
if ( !is_key(*n2) )
return -1;
if ( *n1 < *n2 )
continue;
if ( *n1 > *n2 )
ordered = FALSE;
if ( *n1 == *n2 )
{ if ( ex )
{ term_t t = PL_new_term_ref();
*valTermRef(t) = linkVal(n1);
PL_error(NULL, 0, NULL, ERR_DUPLICATE_KEY, t);
}
return -2;
}
}
return ordered;
}
word
pl_open_dde_conversation(term_t service, term_t topic, term_t handle)
{ UINT i;
HSZ Hservice, Htopic;
if ( !dde_initialise() )
fail;
if ( !get_hsz(service, &Hservice) ||
!get_hsz(topic, &Htopic) )
fail;
/* Establish a connection and get a handle for it */
for (i=0; i < MAX_CONVERSATIONS; i++) /* Find an open slot */
{ if (conv_handle[i] == (HCONV)NULL)
break;
}
if (i == MAX_CONVERSATIONS)
return PL_error(NULL, 0, NULL, ERR_RESOURCE, ATOM_max_dde_handles);
if ( !(conv_handle[i] = DdeConnect(ddeInst, Hservice, Htopic, 0)) )
fail;
DdeFreeStringHandle(ddeInst, Hservice);
DdeFreeStringHandle(ddeInst, Htopic);
return PL_unify_integer(handle, i);
}
static int
defOperator(Module m, atom_t name, int type, int priority, int force)
{ GET_LD
Symbol s;
operator *op;
int t = (type & OP_MASK); /* OP_PREFIX, ... */
DEBUG(7, Sdprintf(":- op(%d, %s, %s) in module %s\n",
priority,
PL_atom_chars(operatorTypeToAtom(type)),
PL_atom_chars(name),
PL_atom_chars(m->name)));
assert(t>=OP_PREFIX && t<=OP_POSTFIX);
if ( !force && !SYSTEM_MODE )
{ if ( name == ATOM_comma ||
(name == ATOM_bar && ((t&OP_MASK) != OP_INFIX ||
(priority < 1001 && priority != 0))) )
{ GET_LD
atom_t action = (name == ATOM_comma ? ATOM_modify : ATOM_create);
term_t t = PL_new_term_ref();
PL_put_atom(t, name);
return PL_error(NULL, 0, NULL, ERR_PERMISSION,
action, ATOM_operator, t);
}
}
LOCK();
if ( !m->operators )
m->operators = newOperatorTable(8);
if ( (s = lookupHTable(m->operators, (void *)name)) )
{ op = s->value;
} else if ( priority < 0 )
{ UNLOCK(); /* already inherited: do not change */
return TRUE;
} else
{ op = allocHeapOrHalt(sizeof(*op));
op->priority[OP_PREFIX] = -1;
op->priority[OP_INFIX] = -1;
op->priority[OP_POSTFIX] = -1;
op->type[OP_PREFIX] = OP_INHERIT;
op->type[OP_INFIX] = OP_INHERIT;
op->type[OP_POSTFIX] = OP_INHERIT;
}
op->priority[t] = priority;
op->type[t] = (priority >= 0 ? type : OP_INHERIT);
if ( !s )
{ PL_register_atom(name);
addHTable(m->operators, (void *)name, op);
}
UNLOCK();
return TRUE;
}
word
pl_convert_time(term_t time, term_t year, term_t month,
term_t day, term_t hour, term_t minute,
term_t second, term_t usec)
{ double tf;
if ( PL_get_float(time, &tf) && tf <= PLMAXINT && tf >= PLMININT )
{ long t = (long) tf;
long us = (long)((tf - (double) t) * 1000.0);
struct tm *tm = LocalTime(&t);
if ( PL_unify_integer(year, tm->tm_year + 1900) &&
PL_unify_integer(month, tm->tm_mon + 1) &&
PL_unify_integer(day, tm->tm_mday) &&
PL_unify_integer(hour, tm->tm_hour) &&
PL_unify_integer(minute, tm->tm_min) &&
PL_unify_integer(second, tm->tm_sec) &&
PL_unify_integer(usec, us) )
succeed;
else
fail;
}
return PL_error("convert_time", 8, NULL, ERR_TYPE, ATOM_time_stamp, time);
}
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 int
bind_varnames(term_t varnames ARG_LD)
{
CACHE_REGS
Term t = Yap_GetFromSlot(varnames);
while(!IsVarTerm(t) && IsPairTerm(t)) {
Term tl = HeadOfTerm(t);
Functor f;
Term tv, t2, t1;
if (!IsApplTerm(tl)) return FALSE;
if ((f = FunctorOfTerm(tl)) != FunctorEq) {
return FALSE;
}
t1 = ArgOfTerm(1, tl);
if (IsVarTerm(t1)) {
return PL_error(NULL, 0, "variable_names", ERR_INSTANTIATION, 0, t1);
}
t2 = ArgOfTerm(2, tl);
tv = Yap_MkApplTerm(LOCAL_FunctorVar, 1, &t1);
if (IsVarTerm(t2)) {
Bind_and_Trail(VarOfTerm(t2), tv);
}
t = TailOfTerm(t);
}
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;
}
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;
}
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
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;
}
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 int
prolog_debug(term_t t, int flag)
{ char *topic;
/* FIXME: handle lists */
if ( !PL_get_chars(t, &topic, CVT_ATOM|CVT_STRING|CVT_EXCEPTION) )
fail;
if ( prolog_debug_topic(topic, flag) )
return TRUE;
return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_debug_topic, t);
}
static int
get_hsz(term_t data, HSZ *rval)
{ char *s;
if ( PL_get_chars(data, &s, CVT_ALL) )
{ HSZ h = DdeCreateStringHandle(ddeInst, s, CP_WINANSI);
if ( h )
{ *rval = h;
succeed;
}
}
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_text, data);
}
static int
allocServerHandle(HCONV handle)
{ int i;
for(i=0; i<MAX_CONVERSATIONS; i++)
{ if ( !server_handle[i] )
{ server_handle[i] = handle;
return i;
}
}
PL_error(NULL, 0, NULL, ERR_RESOURCE, ATOM_max_dde_handles);
return -1;
}
int
PL_get_clref(term_t t, Clause *cl)
{ struct clref *ref;
PL_blob_t *type;
if ( !PL_get_blob(t, (void**)&ref, NULL, &type) ||
type != &clause_blob )
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_db_reference, t);
*cl = ref->clause;
if ( true(ref->clause, CL_ERASED) )
return -1;
return TRUE;
}
int
PL_get_recref(term_t t, RecordRef *rec)
{ struct recref *ref;
PL_blob_t *type;
if ( !PL_get_blob(t, (void**)&ref, NULL, &type) ||
type != &record_blob )
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_db_reference, t);
if ( ref->record->record &&
false(ref->record->record, R_ERASED) )
{ *rec = ref->record;
return TRUE;
}
return FALSE;
}
word
pl_dwim_predicate(term_t pred, term_t dwim, word h)
{ 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) )
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_callable, head);
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;
}
word
pl_dde_request(term_t handle, term_t item,
term_t value, term_t timeout)
{ int hdl;
int rval;
int ddeErr;
HSZ Hitem;
DWORD result, valuelen;
HDDEDATA Hvalue;
long tmo;
if ( !get_conv_handle(handle, &hdl) ||
!get_hsz(item, &Hitem) )
fail;
if ( !PL_get_long(timeout, &tmo) )
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_integer, timeout);
if ( tmo <= 0 )
tmo = TIMEOUT_VERY_LONG;
Hvalue = DdeClientTransaction(NULL, 0, conv_handle[hdl], Hitem, CF_TEXT,
XTYP_REQUEST, (DWORD)tmo, &result);
ddeErr = DdeGetLastError(ddeInst);
DdeFreeStringHandle(ddeInst, Hitem);
if ( Hvalue)
{ char * valuebuf;
char * valuedata;
valuedata = DdeAccessData(Hvalue, &valuelen);
valuebuf = (char *)malloc((size_t)valuelen+1);
strncpy(valuebuf, valuedata, valuelen+1);
DdeUnaccessData(Hvalue);
valuebuf[valuelen] = EOS;
rval = PL_unify_string_chars(value, valuebuf);
free(valuebuf);
return rval;
} else
{ const char * errmsg = dde_error_message(ddeErr);
return PL_unify_term(value,
PL_FUNCTOR, FUNCTOR_error1, /* error(Message) */
PL_CHARS, errmsg);
}
}
static int
globalMPZ(Word at, mpz_t mpz, int flags ARG_LD)
{ DEBUG(CHK_SECURE, assert(!onStackArea(global, at) && !onStackArea(local, at)));
if ( mpz->_mp_alloc )
{ Word p;
size_t size;
size_t wsz = mpz_wsize(mpz, &size);
word m = mkIndHdr(wsz+1, TAG_INTEGER);
if ( wsizeofInd(m) != wsz+1 )
{ PL_error(NULL, 0, NULL, ERR_REPRESENTATION, ATOM_integer);
return 0;
}
if ( !hasGlobalSpace(wsz+3) )
{ int rc = ensureGlobalSpace(wsz+3, flags);
if ( rc != TRUE )
return rc;
}
p = gTop;
gTop += wsz+3;
*at = consPtr(p, TAG_INTEGER|STG_GLOBAL);
*p++ = m;
p[wsz] = 0L; /* pad out */
p[wsz+1] = m;
*p++ = (word)mpz->_mp_size;
memcpy(p, mpz->_mp_d, size);
} else /* already on the stack */
{ Word p = (Word)mpz->_mp_d - 2;
#ifndef NDEBUG
size_t size;
size_t wsz = mpz_wsize(mpz, &size);
assert(p[0] == mkIndHdr(wsz+1, TAG_INTEGER));
#endif
*at = consPtr(p, TAG_INTEGER|STG_GLOBAL);
}
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)
);
}
}
int
raiseStackOverflow(int overflow)
{ GET_LD
Stack s;
switch(overflow)
{ case LOCAL_OVERFLOW: s = (Stack)&LD->stacks.local; break;
case GLOBAL_OVERFLOW: s = (Stack)&LD->stacks.global; break;
case TRAIL_OVERFLOW: s = (Stack)&LD->stacks.trail; break;
case ARGUMENT_OVERFLOW: s = (Stack)&LD->stacks.argument; break;
case MEMORY_OVERFLOW:
return PL_error(NULL, 0, NULL, ERR_NOMEM);
case FALSE: /* some other error is pending */
return FALSE;
default:
s = NULL;
assert(0);
}
return outOfStack(s, STACK_OVERFLOW_RAISE);
}
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);
}
static int
get_hsz(DWORD ddeInst, term_t data, HSZ *rval)
{ wchar_t *s;
size_t len;
if ( PL_get_wchars(data, &len, &s, CVT_ALL|CVT_EXCEPTION) )
{ HSZ h;
assert(s[len] == 0); /* Must be 0-terminated */
DEBUG(2, Sdprintf("Get HSZ for %Ws ...\n", s));
if ( (h=DdeCreateStringHandleW(ddeInst, s, CP_WINUNICODE)) )
{ DEBUG(2, Sdprintf("\tHSZ = %p\n", h));
*rval = h;
succeed;
}
return PL_error(NULL, 0, WinError(), ERR_SYSCALL, "DdeCreateStringHandleW");
}
fail;
}
word
pl_convert_time2(term_t time, term_t string)
{ double tf;
if ( PL_get_float(time, &tf) && tf <= PLMAXINT && tf >= PLMININT )
{ time_t t = (time_t)(long)tf;
char *s = ctime(&t);
if ( s )
{ char *e = s + strlen(s);
while(e>s && e[-1] == '\n')
e--;
*e = EOS;
return PL_unify_string_chars(string, s);
}
return warning("convert_time/2: %s", OsError());
}
return PL_error("convert_time", 2, NULL, ERR_TYPE, ATOM_time_stamp, time);
}
word
pl_getenv(term_t var, term_t value)
{ char *n;
if ( PL_get_chars(var, &n, CVT_ALL) )
{ int len = getenvl(n);
if ( len >= 0 )
{ char *buf = alloca(len+1);
if ( buf )
{ char *s;
if ( (s=getenv3(n, buf, len+1)) )
return PL_unify_atom_chars(value, s);
} else
return PL_error("getenv", 2, NULL, ERR_NOMEM);
}
fail;
}
return warning("getenv/2: instantiation fault");
}
word
pl_dde_register_service(term_t topic, term_t onoff)
{ HSZ t;
int a;
TRY(dde_initialise());
if ( !get_hsz(topic, &t) )
fail;
if ( !PL_get_bool(onoff, &a) )
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_bool, onoff);
if ( !a )
{ int rval = (int)DdeNameService(ddeInst, t, 0L, DNS_UNREGISTER);
DdeFreeStringHandle(ddeInst, t);
return rval ? TRUE : FALSE;
} else
{ if ( DdeNameService(ddeInst, t, 0L, DNS_REGISTER|DNS_FILTERON) )
succeed; /* should we free too? */
DdeFreeStringHandle(ddeInst, t);
return dde_warning("register_request");
}
}