/* calculate approximate length of a printed term. For space alloc. */
DWORD clenpterm(prolog_term term)
{
int i, clen;
if (is_var(term)) return 11;
else if (is_int(term)) return 12;
else if (is_float(term)) return 12;
else if (is_nil(term)) return 2;
else if (is_string(term)) return strlen(p2c_string(term))+5;
else if (is_list(term)) {
clen = 1;
clen += clenpterm(p2p_car(term)) + 1;
while (is_list(term)) {
clen += clenpterm(p2p_car(term)) + 1;
term = p2p_cdr(term);
}
if (!is_nil(term)) {
clen += clenpterm(term) + 1;
}
return clen+1;
} else if (is_functor(term)) {
clen = strlen(p2c_functor(term))+5;
if (p2c_arity(term) > 0) {
clen += clenpterm(p2p_arg(term,1)) + 1;
for (i = 2; i <= p2c_arity(term); i++) {
clen += clenpterm(p2p_arg(term,i)) + 1;
}
return clen + 1;
} else return clen;
} else {
fprintf(stderr,"error, unrecognized type");
return 0;
}
}
/* print a prolog_term into a buffer.
(Atoms are quoted if !toplevel and it's necessary for Prolog reading) */
void printpterm(prolog_term term, int toplevel, char *straddr, long int *ind)
{
int i;
if (is_var(term)) {
sprintf(tempstring,"_%p",term);
strcpy(straddr+*ind,tempstring);
*ind += strlen(tempstring);
} else if (is_int(term)) {
sprintf(tempstring,"%d",p2c_int(term));
strcpy(straddr+*ind,tempstring);
*ind += strlen(tempstring);
} else if (is_float(term)) {
sprintf(tempstring,"%f",p2c_float(term));
strcpy(straddr+*ind,tempstring);
*ind += strlen(tempstring);
} else if (is_nil(term)) {
strcpy(straddr+*ind,"[]");
*ind += 2;
} else if (is_string(term)) {
printpstring(p2c_string(term),toplevel,straddr,ind);
} else if (is_list(term)) {
strcpy(straddr+*ind,"[");
*ind += 1;
printpterm(p2p_car(term),FALSE,straddr,ind);
term = p2p_cdr(term);
while (is_list(term)) {
strcpy(straddr+*ind,",");
*ind += 1;
printpterm(p2p_car(term),FALSE,straddr,ind);
term = p2p_cdr(term);
}
if (!is_nil(term)) {
strcpy(straddr+*ind,"|");
*ind += 1;
printpterm(term,FALSE,straddr,ind);
}
strcpy(straddr+*ind,"]");
*ind += 1;
} else if (is_functor(term)) {
printpstring(p2c_functor(term),FALSE,straddr,ind);
if (p2c_arity(term) > 0) {
strcpy(straddr+*ind,"(");
*ind += 1;
printpterm(p2p_arg(term,1),FALSE,straddr,ind);
for (i = 2; i <= p2c_arity(term); i++) {
strcpy(straddr+*ind,",");
*ind += 1;
printpterm(p2p_arg(term,i),FALSE,straddr,ind);
}
strcpy(straddr+*ind,")");
*ind += 1;
}
} else fprintf(stderr,"error, unrecognized type");
}
/* file_stat(+FileName, +FuncNumber, -Result) */
xsbBool file_stat(CTXTdeclc int callno, char *file)
{
struct stat stat_buff;
int retcode;
#ifdef WIN_NT
size_t filenamelen; // windows doesn't allow trailing slash, others do
filenamelen = strlen(file);
if (file[filenamelen-1] == '/' || file[filenamelen-1] == '\\') {
char ss = file[filenamelen-1];
file[filenamelen-1] = '\0';
retcode = stat(file, &stat_buff);
file[filenamelen-1] = ss; // reset
} else
#endif
retcode = stat(file, &stat_buff);
switch (callno) {
case IS_PLAIN_FILE: {
if (retcode == 0 && S_ISREG(stat_buff.st_mode))
return TRUE;
else return FALSE;
}
case IS_DIRECTORY: {
if (retcode == 0 && S_ISDIR(stat_buff.st_mode))
return TRUE;
else return FALSE;
}
case STAT_FILE_TIME: {
/* This is DSW's hack to get 32 bit time values.
The idea is to call this builtin as file_time(File,time(T1,T2))
where T1 represents the most significant 8 bits and T2 represents
the least significant 24.
***This probably breaks 64 bit systems, so David will look into it!
*/
int functor_arg3 = isconstr(reg_term(CTXTc 3));
if (!retcode && functor_arg3) {
/* file exists & arg3 is a term, return 2 words*/
c2p_int(CTXTc (prolog_int)(stat_buff.st_mtime >> 24),p2p_arg(reg_term(CTXTc 3),1));
c2p_int(CTXTc 0xFFFFFF & stat_buff.st_mtime,p2p_arg(reg_term(CTXTc 3),2));
} else if (!retcode) {
/* file exists, arg3 non-functor: issue an error */
ctop_int(CTXTc 3, (prolog_int)stat_buff.st_mtime);
} else if (functor_arg3) {
/* no file, and arg3 is functor: return two 0's */
c2p_int(CTXTc 0, p2p_arg(reg_term(CTXTc 3),2));
c2p_int(CTXTc 0, p2p_arg(reg_term(CTXTc 3),1));
} else {
/* no file, no functor: return 0 */
ctop_int(CTXTc 3, 0);
}
return TRUE;
}
/*
* call as: equal_datime(T1,T2)
* Checks if T1 and T2 are the same date
*/
int equal_datime(CTXTdecl)
{
prolog_term t1 = reg_term(CTXTc 1);
prolog_term t2 = reg_term(CTXTc 2);
if(!is_functor(t1) && !is_functor(t2))
return FALSE;
int t1_ts = p2c_int(p2p_arg(t1,1));
int t2_ts = p2c_int(p2p_arg(t2,1));
if (t1_ts==t2_ts)
return TRUE;
else
return FALSE;
}
DllExport int call_conv fibr(CTXTdecl) {
int inarg, f1, f2;
inarg = p2c_int(reg_term(CTXTc 1)); // get the input argument
if (inarg <= 1) { // if small, return answer directly
c2p_int(CTXTc 1,reg_term(CTXTc 2));
return TRUE;
}
xsb_query_save(CTXTc 2); // prepare for calling XSB
c2p_functor(CTXTc "fibp",2,reg_term(CTXTc 1)); // setup call
c2p_int(CTXTc inarg-1,p2p_arg(reg_term(CTXTc 1),1)); // and inp arg
if (xsb_query(CTXT)) { // call XSB
printf("Error calling fibp 1.\n");
fflush(stdout);
return FALSE;
}
f1 = p2c_int(p2p_arg(reg_term(CTXTc 1),2)); // get answer
if (xsb_close_query(CTXT)) { // throw away other (nonexistent) answers
printf("Error closing fibp 1.\n");
fflush(stdout);
return FALSE;
}
c2p_functor(CTXTc "fibp",2,reg_term(CTXTc 1)); // prepare for 2nd call to XSB
c2p_int(CTXTc inarg-2,p2p_arg(reg_term(CTXTc 1),1)); // and its inp arg
if (xsb_query(CTXT)) { // and call query
printf("Error calling fibp 2.\n");
fflush(stdout);
return FALSE;
}
f2 = p2c_int(p2p_arg(reg_term(CTXTc 1),2)); // and get its answer
if (xsb_next(CTXT) != XSB_FAILURE) { // get next answer, which must NOT exist
printf("Error getting next fibp 2.\n");
fflush(stdout);
return FALSE;
}
if (xsb_query_restore(CTXT)) { // restore regs to prepare for exit
printf("Error finishing.\n");
fflush(stdout);
return FALSE;
}
c2p_int(CTXTc f1+f2,reg_term(CTXTc 2)); // set our answer
return TRUE; // and return successfully
}
int return_to_prolog(PyObject *pValue)
{
if(pValue == Py_None){
return 1;
}
if(PyInt_Check(pValue))
{
int result = PyInt_AS_LONG(pValue);
extern_ctop_int(3, result);
return 1;
}
else if(PyFloat_Check(pValue))
{
float result = PyFloat_AS_DOUBLE(pValue);
extern_ctop_float(3, result);
return 1;
}else if(PyString_Check(pValue))
{
char *result = PyString_AS_STRING(pValue);
extern_ctop_string(3, result);
return 1;
}else if(PyList_Check(pValue))
{
size_t size = PyList_Size(pValue);
size_t i = 0;
prolog_term head, tail;
prolog_term P = p2p_new();
tail = P;
for(i = 0; i < size; i++)
{
c2p_list(CTXTc tail);
head = p2p_car(CTXTc tail);
PyObject *pyObj = PyList_GetItem(pValue, i);
int temp = PyInt_AS_LONG(pyObj);
c2p_int(temp, head);
//convert_pyObj_prObj(pyObj, &head);
tail = p2p_cdr(tail);
}
c2p_nil(CTXTc tail);
p2p_unify(P, reg_term(CTXTc 3));
return 1;
}else
{
//returns an object refernce to prolog side.
pyobj_ref_node *node = add_pyobj_ref_list(pValue);
//printf("node : %p", node);
char str[30];
sprintf(str, "%p", node);
//extern_ctop_string(3,str);
prolog_term ref = p2p_new();
c2p_functor("pyObject", 1, ref);
prolog_term ref_inner = p2p_arg(ref, 1);
c2p_string(str, ref_inner);
p2p_unify(ref, reg_term(CTXTc 3));
return 1;
}
return 0;
}
//todo: need to refactor this code.
int callpy(CTXTdecl)
{
setenv("PYTHONPATH", ".", 1);
PyObject *pName = NULL, *pModule = NULL, *pFunc = NULL;
PyObject *pArgs = NULL, *pValue = NULL;
//PyObject *pArgs, *pValue;
prolog_term V, temp;
Py_Initialize();
char *module = ptoc_string(CTXTdeclc 1);
//char *function = ptoc_string(CTXTdeclc 2);
pName = PyString_FromString(module);
pModule = PyImport_Import(pName);
if(pModule == NULL)
{
return FALSE;
}
Py_DECREF(pName);
V = extern_reg_term(2);
char *function = p2c_functor(V);
if(is_functor(V))
{
int args_count = p2c_arity(V);
pFunc = PyObject_GetAttrString(pModule, function);
Py_DECREF(pModule);
if(pFunc && PyCallable_Check(pFunc))
{
pArgs = PyTuple_New(args_count);
int i;
for(i = 1; i <= args_count; i++)
{
temp = p2p_arg(V, i);
if(!(set_python_argument(temp, pArgs, i)))
{
return FALSE;
}
}
}
else
{
return FALSE;
}
pValue = PyObject_CallObject(pFunc, pArgs);
//printf("return call : %p\n",pValue);
if(return_to_prolog(pValue))
return TRUE;
else
return FALSE;
}
else
{
return FALSE;
}
return TRUE;
}
/* file_stat(+FileName, +FuncNumber, -Result) */
xsbBool file_stat(CTXTdeclc int callno, char *file)
{
struct stat stat_buff;
int retcode = stat(file, &stat_buff);
switch (callno) {
case IS_PLAIN_FILE: {
if (retcode == 0 && S_ISREG(stat_buff.st_mode))
return TRUE;
else return FALSE;
}
case IS_DIRECTORY: {
if (retcode == 0 && S_ISDIR(stat_buff.st_mode))
return TRUE;
else return FALSE;
}
case STAT_FILE_TIME: {
/* This is DSW's hack to get 32 bit time values.
The idea is to call this builtin as file_time(File,time(T1,T2))
where T1 represents the most significant 8 bits and T2 represents
the least significant 24.
***This probably breaks 64 bit systems, so David will look into it!
*/
int functor_arg3 = isconstr(reg_term(CTXTc 3));
if (!retcode && functor_arg3) {
/* file exists & arg3 is a term, return 2 words*/
c2p_int(CTXTc stat_buff.st_mtime >> 24,p2p_arg(reg_term(CTXTc 3),1));
c2p_int(CTXTc 0xFFFFFF & stat_buff.st_mtime,p2p_arg(reg_term(CTXTc 3),2));
} else if (!retcode) {
/* file exists, arg3 non-functor: issue an error */
xsb_warn("Arg 3 (the time argument) must be of the form time(X,Y)");
ctop_int(CTXTc 3, (0x7FFFFFF & stat_buff.st_mtime));
} else if (functor_arg3) {
/* no file, and arg3 is functor: return two 0's */
c2p_int(CTXTc 0, p2p_arg(reg_term(CTXTc 3),2));
c2p_int(CTXTc 0, p2p_arg(reg_term(CTXTc 3),1));
} else {
/* no file, no functor: return 0 */
xsb_warn("Arg 3 (the time argument) must be of the form time(X,Y)");
ctop_int(CTXTc 3, 0);
}
return TRUE;
}
int main(int argc, char *argv[])
{
int rc;
int return_size = 15;
char *return_string;
return_string = malloc(return_size);
int myargc = 1;
char *myargv[1];
myargv[0] = strip_names_from_path(xsb_executable_full_path(argv[0]),3);
if (xsb_init(myargc,myargv)) {
fprintf(stderr,"%s initializing XSB: %s\n",xsb_get_init_error_type(),
xsb_get_init_error_message());
exit(XSB_ERROR);
}
#ifdef MULTI_THREAD
th_context *th = xsb_get_main_thread();
#define xsb_get_main_thread_macro() xsb_get_main_thread()
#else
#define xsb_get_main_thread_macro()
#endif
c2p_functor(CTXTc "consult",1,reg_term(CTXTc 1));
c2p_string(CTXTc "edb.P",p2p_arg(reg_term(CTXTc 1),1));
/* Create command to consult a file: edb.P, and send it. */
if (xsb_command(CTXT) == XSB_ERROR)
fprintf(stderr,"++Error consulting edb.P: %s/%s\n",
xsb_get_error_type(xsb_get_main_thread_macro()),
xsb_get_error_message(xsb_get_main_thread_macro()));
c2p_functor(CTXTc "pregs",3,reg_term(CTXTc 1));
rc = xsb_query(CTXT);
while (rc == XSB_SUCCESS) {
printf("Answer: pregs(%s,%s,%s)\n",
xsb_var_string(1),xsb_var_string(2),xsb_var_string(2));
rc = xsb_next(CTXT);
}
if (rc == XSB_ERROR)
fprintf(stderr,"++Query Error: %s/%s\n",
xsb_get_error_type(xsb_get_main_thread_macro()),
xsb_get_error_message(xsb_get_main_thread_macro()));
xsb_close(CTXT);
return(0);
}
/* call as: current_datime(-D)
Returns the predicate datime(D) where D is the current time in ms*/
int current_datime(CTXTdecl)
{
time_t now;
time(&now);
prolog_term t = reg_term(CTXTc 1);
if (is_functor(t))
{
char *func = p2c_functor(t);
if(strcmp(func,"datime")==0)
{
c2p_int(CTXTc now, p2p_arg(reg_term(CTXTc 1),1));
return TRUE;
}
return FALSE;
}
c2p_functor(CTXTc "datime",1,reg_term(CTXTc 1));
c2p_int(CTXTc now, p2p_arg(reg_term(CTXTc 1),1));
return TRUE;
}
/*
* call as: datime_minus_datime(T1,T2,Sec)
* Returns Sec as the diff in seconds between T1 and T2
*/
int datime_minus_datime(CTXTdecl)
{
prolog_term t1 = reg_term(CTXTc 1);
prolog_term t2 = reg_term(CTXTc 2);
if(!is_functor(t1) && !is_functor(t2))
return FALSE;
int t1_ts = p2c_int(p2p_arg(t1,1));
int t2_ts = p2c_int(p2p_arg(t2,1));
int diff = 0;
if(t1_ts < t2_ts)
diff = t2_ts - t1_ts;
else
diff = t1_ts - t2_ts;
c2p_int(CTXTc diff,reg_term(CTXTc 3));
return TRUE;
}
/*
* call as: between_datime(+T1,+T2,+T3)
* Checks if T1 is between T2 and T3
*/
int between_datime(CTXTdecl)
{
prolog_term t1 = reg_term(CTXTc 1);
prolog_term t2 = reg_term(CTXTc 2);
prolog_term t3 = reg_term(CTXTc 3);
if (!is_functor(t1) && !is_functor(t2) && !is_functor(t3))
return FALSE;
int t1_arity = p2c_arity(t1);
int t2_arity = p2c_arity(t2);
int t3_arity = p2c_arity(t3);
int t1_ts = p2c_int(p2p_arg(t1,1));
int t2_ts = p2c_int(p2p_arg(t2,1));
int t3_ts = p2c_int(p2p_arg(t3,1));
int t1_coun = 0;
int t2_coun = 0;
int t3_coun = 0;
if ( t1_arity > 1 && t2_arity > 1 && t3_arity > 1 )
{
t1_coun = p2c_int(p2p_arg(t1,2));
t2_coun = p2c_int(p2p_arg(t2,2));
t3_coun = p2c_int(p2p_arg(t3,2));
}
return aux_less_datime(t2_ts,t1_ts,t2_coun,t1_coun) &&
aux_less_datime(t1_ts,t3_ts,t1_coun,t3_coun);
}
void *close_query_rs(void * arg) {
int rc;
th_context *r_th;
pthread_mutex_lock(&user_r_ready_mut);
r_th = (th_context *)arg;
c2p_functor(r_th, "rregs",3,reg_term(r_th, 1));
rc = xsb_query(r_th);
if (rc == XSB_ERROR)
fprintf(stderr,"++Closed query Error r: %s/%s\n",
xsb_get_error_type(r_th),xsb_get_error_message(r_th));
printf("Closed return r(%d,%d,%d)\n",
(p2c_int(p2p_arg(reg_term(r_th, 2),1))),
(p2c_int(p2p_arg(reg_term(r_th, 2),2))),
(p2c_int(p2p_arg(reg_term(r_th, 2),3))));
rc = xsb_close_query(r_th);
if (rc == XSB_FAILURE)
fprintf(stderr,"++Failure on closed query (r)!\n");
pthread_mutex_unlock(&user_r_ready_mut);
return NULL;
}
/*******************************************************************
Closed queries
*********************************************************************/
void *close_query_ps(void * arg) {
int rc;
th_context *p_th;
pthread_mutex_lock(&user_p_ready_mut);
p_th = (th_context *)arg;
c2p_functor(p_th, "pregs",3,reg_term(p_th, 1));
rc = xsb_query(p_th);
if (rc == XSB_ERROR)
fprintf(stderr,"++Closed query Error p: %s/%s\n",
xsb_get_error_type(p_th),xsb_get_error_message(p_th));
printf("Closed return p(%s,%s,%s)\n",
(p2c_string(p2p_arg(reg_term(p_th, 2),1))),
(p2c_string(p2p_arg(reg_term(p_th, 2),2))),
(p2c_string(p2p_arg(reg_term(p_th, 2),3))));
rc = xsb_close_query(p_th);
if (rc == XSB_FAILURE)
fprintf(stderr,"++Failure on closed query (p)!\n");
pthread_mutex_unlock(&user_p_ready_mut);
return NULL;
}
/*
* call as: less_datime(T1,T2)
* Return true if T1 is an older date than T2
*/
int less_datime(CTXTdecl)
{
prolog_term t1 = reg_term(CTXTc 1);
prolog_term t2 = reg_term(CTXTc 2);
if (!is_functor(t1) || !is_functor(t2))
{
return FALSE;
}
int t1_arity = p2c_arity(t1);
int t2_arity = p2c_arity(t2);
int t1_ts = p2c_int(p2p_arg(t1,1));
int t2_ts = p2c_int(p2p_arg(t2,1));
int t1_coun = 0;
int t2_coun = 0;
if ( t1_arity > 1 && t2_arity > 1 )
{
t1_coun = p2c_int(p2p_arg(t1,2));
t2_coun = p2c_int(p2p_arg(t2,2));
}
return aux_less_datime(t1_ts,t2_ts,t1_coun,t2_coun);
}
/*
* call as: datime_plus_sec(T1,Sec,T2)
* Returns T2 as the result of date T1 plus Sec seconds
*/
int datime_plus_sec(CTXTdecl)
{
prolog_term t1 = reg_term(CTXTc 1);
if(!is_functor(t1))
return FALSE;
int t1_ts = p2c_int(p2p_arg(t1,1));
int sec = p2c_int(reg_term(CTXTc 2));
if (p2c_arity(t1) > 1)
{
int counter = p2p_arg(t1,2);
c2p_functor(CTXTc "datime",2,reg_term(CTXTc 3));
c2p_int(CTXTc t1_ts+sec,p2p_arg(reg_term(CTXTc 3),1));
c2p_int(CTXTc counter,p2p_arg(reg_term(CTXTc 3),2));
}
else
{
c2p_functor(CTXTc "datime",1,reg_term(CTXTc 3));
c2p_int(CTXTc t1_ts+sec,p2p_arg(reg_term(CTXTc 3),1));
}
return TRUE;
}
void *query_rs_err(void * arg) {
int rc;
th_context *r_th;
pthread_mutex_lock(&user_r_ready_mut);
r_th = (th_context *)arg;
c2p_functor(r_th, "rregs_err",3,reg_term(r_th, 1));
rc = xsb_query(r_th);
while (rc == XSB_SUCCESS) {
printf("Pre-err return r(%d,%d,%d)\n",
(p2c_int(p2p_arg(reg_term(r_th, 2),1))),
(p2c_int(p2p_arg(reg_term(r_th, 2),2))),
(p2c_int(p2p_arg(reg_term(r_th, 2),3))));
rc = xsb_next(r_th);
}
if (rc == XSB_ERROR)
fprintf(stderr,"Planned query Error r: %s/%s\n",
xsb_get_error_type(r_th),xsb_get_error_message(r_th));
pthread_mutex_unlock(&user_r_ready_mut);
return NULL;
}
/*******************************************************************
Successful queries
*********************************************************************/
void *query_ps(void * arg) {
int rc;
th_context *p_th;
pthread_mutex_lock(&user_p_ready_mut);
p_th = (th_context *)arg;
c2p_functor(p_th, "pregs",3,reg_term(p_th, 1));
rc = xsb_query(p_th);
while (rc == XSB_SUCCESS) {
printf("Answer: pregs(%s,%s,%s)\n",
(p2c_string(p2p_arg(reg_term(p_th, 2),1))),
(p2c_string(p2p_arg(reg_term(p_th, 2),2))),
(p2c_string(p2p_arg(reg_term(p_th, 2),3))));
rc = xsb_next(p_th);
}
if (rc == XSB_ERROR)
fprintf(stderr,"++Query Error p: %s/%s\n",
xsb_get_error_type(p_th),xsb_get_error_message(p_th));
pthread_mutex_unlock(&user_p_ready_mut);
return NULL;
}
static int bindReturnList(prolog_term returnList, struct xsb_data** result, struct xsb_queryHandle* qHandle)
{
prolog_term element;
char* temp;
char c;
int i, j;
int rFlag;
if (is_nil(returnList) && result == NULL) {
rFlag = RESULT_NONEMPTY_OR_NOT_REQUESTED;
}
if (!is_nil(returnList) && result == NULL && qHandle->state == QUERY_BEGIN) {
errorMesg = "XSB_DBI_ERROR: Invalid return list in query";
errorNumber = "XSB_DBI_013";
rFlag = INVALID_RETURN_LIST;
}
else if (!is_nil(returnList) && result == NULL) {
while (!is_nil(returnList)) {
element = p2p_car(returnList);
c2p_nil(CTXTc element);
returnList = p2p_cdr(returnList);
}
rFlag = RESULT_EMPTY_BUT_REQUESTED;
}
i = 0;
if (result != NULL) {
while (!is_nil(returnList)) {
if (qHandle->numResultCols <= i) {
errorMesg = "XSB_DBI ERROR: Number of requested columns exceeds the number of columns in the query";
errorNumber = "XSB_DBI_011";
rFlag = TOO_MANY_RETURN_COLS;
return rFlag;
}
element = p2p_car(returnList);
if (result == NULL) {
c2p_nil(CTXTc element);
}
else if (is_var(element) && result[i]->type == STRING_TYPE) {
if (result[i]->val == NULL)
c2p_nil(CTXTc element);
else {
c = result[i]->val->str_val[0];
if (c == DB_INTERFACE_TERM_SYMBOL) {
temp = (char *)malloc(strlen(result[i]->val->str_val) * sizeof(char));
for (j = 1 ; j < (int)strlen(result[i]->val->str_val) ; j++) {
temp[j-1] = result[i]->val->str_val[j];
}
temp[strlen(result[i]->val->str_val) - 1] = '\0';
c2p_functor(CTXTc "term", 1, element);
c2p_string(CTXTc temp, p2p_arg(element, 1));
if (temp != NULL) {
free(temp);
temp = NULL;
}
}
else {
c2p_string(CTXTc result[i]->val->str_val, element);
}
}
}
else if (is_var(element) && result[i]->type == INT_TYPE)
c2p_int(CTXTc result[i]->val->i_val, element);
else if (is_var(element) && result[i]->type == FLOAT_TYPE)
c2p_float(CTXTc result[i]->val->f_val, element);
returnList = p2p_cdr(returnList);
i++;
}
rFlag = RESULT_NONEMPTY_OR_NOT_REQUESTED;
}
if (result != NULL && qHandle->numResultCols > i) {
errorMesg = "XSB_DBI ERROR: Number of requested columns is less than the number of returned columns";
errorNumber = "XSB_DBI_012";
rFlag = TOO_FEW_RETURN_COLS;
return rFlag;
}
return rFlag;
}
HDDEDATA FAR PASCAL _export DdeCallback(UINT type, UINT fmt,
HCONV hConv, HSZ hsz1, HSZ hsz2,
HDDEDATA data, DWORD data1,
DWORD data2)
{
long int ind, i, spaceneeded, sizeQuery;
DWORD Qlen, QSegLen;
static HCONV handConv;
static HDDEDATA hdDataHandle;
/*DdeQueryString(idInst,hsz1,szBuff1,sizeof(szBuff1),0);
DdeQueryString(idInst,hsz2,szBuff2,sizeof(szBuff2),0);
fprintf(stderr,"DDE Callback, type=%d, fmt=%d, hConv=%d, hsz1=%s, hsz2=%s,\n d1=%x, d2=%x\n",
type,fmt,hConv,szBuff1,szBuff2,data1,data2);*/
switch (type) {
case XTYP_ERROR:
fprintf(stderr,"error: xtyp_error\n");
return NULL;
case XTYP_ADVDATA:
fprintf(stderr,"DDE msg received ADVDATA\n");
return DDE_FNOTPROCESSED;
case XTYP_ADVREQ:
fprintf(stderr,"DDE msg received ADVREQ\n");
return NULL;
case XTYP_ADVSTART:
fprintf(stderr,"DDE msg received ADVSTART\n");
return NULL;
case XTYP_ADVSTOP:
fprintf(stderr,"DDE msg received ADVSTOP\n");
return NULL;
case XTYP_CONNECT:
DdeQueryString(idInst,hsz2,szBuffer,sizeof(szBuffer),0);
if (strcmp(szBuffer,szAppName)) return FALSE;
Qlen = DdeQueryString(idInst,hsz1,NULL,0,0);
szQuery = (char *)malloc(Qlen+1);
(void)DdeQueryString(idInst,hsz1,szQuery,Qlen+1,0);
if (!strcmp(szQuery,"XSB")) {
free(szQuery);
szQuery = NULL;
}
return TRUE;
case XTYP_CONNECT_CONFIRM:
handConv = hConv;
return TRUE;
case XTYP_DISCONNECT:
return NULL;
case XTYP_EXECUTE:
fprintf(stderr,"DDE msg received EXECUTE\n");
return DDE_FNOTPROCESSED;
case XTYP_POKE:
QSegLen = DdeGetData(data,NULL,100000,0L);
if (!szQuery) {
szQuery = (char *)malloc(QSegLen);
QSegLen = DdeGetData(data,szQuery,100000,0L);
sizeQuery = QSegLen;
} else {
szQuery = (char *)realloc(szQuery,sizeQuery+QSegLen+1);
QSegLen = DdeGetData(data,szQuery+sizeQuery,100000,0L);
sizeQuery =+ QSegLen;
}
return DDE_FACK;
case XTYP_REGISTER:
fprintf(stderr,"DDE msg received REGISTER\n");
return NULL;
case XTYP_REQUEST:
/*fprintf(stderr,"DDE msg received REQUEST:\n");*/
if (!szQuery) return NULL;
if (sizeBuff3 < 10) {
szBuff3 = (char *)malloc(initsizeBuff3);
sizeBuff3 = initsizeBuff3;
}
ind = 0;
rcode = xsb_query_string(szQuery); /* call the query */
if (rcode) {
strcpy(szBuff3+ind,"no\r");
ind += 3;
} else if (is_string(reg_term(2)) || p2c_arity(reg_term(2))==0) {
strcpy(szBuff3+ind,"yes\r");
ind += 4;
while (!rcode) rcode = xsb_next();
} else while (!rcode) {
spaceneeded = ind + clenpterm(reg_term(2)) + 20; /* fudge factor */
if (spaceneeded > sizeBuff3) {
while (spaceneeded > sizeBuff3) {sizeBuff3 = 2*sizeBuff3;}
szBuff3 = realloc(szBuff3,sizeBuff3);
}
for (i=1; i<p2c_arity(reg_term(2)); i++) {
printpterm(p2p_arg(reg_term(2),i),TRUE,szBuff3,&ind);
strcpy(szBuff3+ind,"\t");
ind += 1;
}
printpterm(p2p_arg(reg_term(2),p2c_arity(reg_term(2))),TRUE,szBuff3,&ind);
strcpy(szBuff3+ind,"\r");
ind += 1;
rcode = xsb_next();
}
hdDataHandle = DdeCreateDataHandle(idInst,szBuff3,ind+1,0,hsz2,CF_TEXT,0);
free(szQuery);
szQuery = NULL;
return hdDataHandle;
case XTYP_WILDCONNECT:
fprintf(stderr,"DDE msg received WILDCONNECT\n");
return NULL;
default:
fprintf(stderr,"DDE msg received: %d\n",type);
}
return NULL;
}
int set_python_argument(prolog_term temp, PyObject *pArgs,int i)
{
PyObject *pValue;
if(find_prolog_term_type(temp) == INT)
{
prolog_term argument = temp;
int argument_int = p2c_int(argument);
pValue = PyInt_FromLong(argument_int);
PyTuple_SetItem(pArgs, i-1, pValue);
}else if(find_prolog_term_type(temp) == STRING)
{
prolog_term argument = temp;
char *argument_char = p2c_string(argument);
//printf("%s", argument_char);
pValue = PyString_FromString(argument_char);
PyTuple_SetItem(pArgs, i-1, pValue);
}else if(find_prolog_term_type(temp) == FLOAT)
{
prolog_term argument = temp;
float argument_float = p2c_float(argument);
pValue = PyFloat_FromDouble(argument_float);
PyTuple_SetItem(pArgs, i-1, pValue);
}
else if(find_prolog_term_type(temp) == LIST)
{
prolog_term argument = temp;
int count = find_length_prolog_list(argument);
PyObject *pList = PyList_New(count);
if (! prlist2pyList(argument, pList, count))
return FALSE;
PyTuple_SetItem(pArgs, i-1, pList);
}
else if (find_prolog_term_type(temp) == FUNCTOR)
{
//region begin : handle pyobject term
if(strcmp(p2c_functor(temp),"pyObject") == 0)
{
prolog_term ref = p2p_arg(temp, 1);
char *node_pointer = p2c_string(ref);
pyobj_ref_node *pyobj_ref = (pyobj_ref_node *)strtol(node_pointer,NULL, 0);
//pyobj_ref_node *node = (pyobj_ref_node *)(node_pointer);
pValue = pyobj_ref->python_obj;
//printf("set_argN: %p %zu" , pValue, pyobj_ref->ref_id);
PyTuple_SetItem(pArgs, i - 1 , pValue);
}
//end region
}
// else if(find_prolog_term_type(temp) == REF)
// { //when a reference is passed.
// prolog_term argument = temp;
// char *argument_ref = p2c_string(argument);
// if(strncmp("ref_", argument_ref, 4)== 0 )
// { //gets the reference id from the string and finds it in the list
// argument_ref = argument_ref + 4;
// size_t ref = strtoul(argument_ref, NULL, 0);
// PyObject *obj = get_pyobj_ref_list(ref);
// if(obj == NULL)
// return FALSE;
// PyTuple_SetItem(pArgs, i-1, obj);
// }
// }
return TRUE;
}
/* XSB string substitution entry point: replace substrings specified in Arg2
with strings in Arg3.
In:
Arg1: string
Arg2: substring specification, a list [s(B1,E1),s(B2,E2),...]
Arg3: list of replacement string
Out:
Arg4: new (output) string
Always succeeds, unless error.
*/
int do_regsubstitute__(void)
{
#ifdef MULTI_THREAD
if( NULL == th)
th = xsb_get_main_thread();
#endif
/* Prolog args are first assigned to these, so we could examine the types
of these objects to determine if we got strings or atoms. */
prolog_term input_term, output_term;
prolog_term subst_reg_term, subst_spec_list_term, subst_spec_list_term1;
prolog_term subst_str_term=(prolog_term)0,
subst_str_list_term, subst_str_list_term1;
char *input_string=NULL; /* string where matches are to be found */
char *subst_string=NULL;
prolog_term beg_term, end_term;
int beg_offset=0, end_offset=0, input_len;
int last_pos = 0; /* last scanned pos in input string */
/* the output buffer is made large enough to include the input string and the
substitution string. */
int conversion_required=FALSE; /* from C string to Prolog char list */
XSB_StrSet(&output_buffer,"");
input_term = reg_term(CTXTc 1); /* Arg1: string to find matches in */
if (is_string(input_term)) /* check it */
input_string = string_val(input_term);
else if (is_list(input_term)) {
input_string = p_charlist_to_c_string(CTXTc input_term, &input_buffer,
"RE_SUBSTITUTE", "input string");
conversion_required = TRUE;
} else
xsb_abort("[RE_SUBSTITUTE] Arg 1 (the input string) must be an atom or a character list");
input_len = strlen(input_string);
/* arg 2: substring specification */
subst_spec_list_term = reg_term(CTXTc 2);
if (!is_list(subst_spec_list_term) && !is_nil(subst_spec_list_term))
xsb_abort("[RE_SUBSTITUTE] Arg 2 must be a list [s(B1,E1),s(B2,E2),...]");
/* handle substitution string */
subst_str_list_term = reg_term(CTXTc 3);
if (! is_list(subst_str_list_term))
xsb_abort("[RE_SUBSTITUTE] Arg 3 must be a list of strings");
output_term = reg_term(CTXTc 4);
if (! is_var(output_term))
xsb_abort("[RE_SUBSTITUTE] Arg 4 (the output) must be an unbound variable");
subst_spec_list_term1 = subst_spec_list_term;
subst_str_list_term1 = subst_str_list_term;
if (is_nil(subst_spec_list_term1)) {
XSB_StrSet(&output_buffer, input_string);
goto EXIT;
}
if (is_nil(subst_str_list_term1))
xsb_abort("[RE_SUBSTITUTE] Arg 3 must not be an empty list");
do {
subst_reg_term = p2p_car(subst_spec_list_term1);
subst_spec_list_term1 = p2p_cdr(subst_spec_list_term1);
if (!is_nil(subst_str_list_term1)) {
subst_str_term = p2p_car(subst_str_list_term1);
subst_str_list_term1 = p2p_cdr(subst_str_list_term1);
if (is_string(subst_str_term)) {
subst_string = string_val(subst_str_term);
} else if (is_list(subst_str_term)) {
subst_string = p_charlist_to_c_string(CTXTc subst_str_term, &subst_buf,
"RE_SUBSTITUTE",
"substitution string");
} else
xsb_abort("[RE_SUBSTITUTE] Arg 3 must be a list of strings");
}
beg_term = p2p_arg(subst_reg_term,1);
end_term = p2p_arg(subst_reg_term,2);
if (!is_int(beg_term) || !is_int(end_term))
xsb_abort("[RE_SUBSTITUTE] Non-integer in Arg 2");
else{
beg_offset = int_val(beg_term);
end_offset = int_val(end_term);
}
/* -1 means end of string */
if (end_offset < 0)
end_offset = input_len;
if ((end_offset < beg_offset) || (beg_offset < last_pos))
xsb_abort("[RE_SUBSTITUTE] Substitution regions in Arg 2 not sorted");
/* do the actual replacement */
XSB_StrAppendBlk(&output_buffer,input_string+last_pos,beg_offset-last_pos);
XSB_StrAppend(&output_buffer, subst_string);
last_pos = end_offset;
} while (!is_nil(subst_spec_list_term1));
XSB_StrAppend(&output_buffer, input_string+end_offset);
EXIT:
/* get result out */
if (conversion_required)
c_string_to_p_charlist(CTXTc output_buffer.string, output_term, 4,
"RE_SUBSTITUTE", "Arg 4");
else
/* DO NOT intern. When atom table garbage collection is in place, then
replace the instruction with this:
c2p_string(output_buffer, output_term);
The reason for not interning is that in Web page
manipulation it is often necessary to process the same string many
times. This can cause atom table overflow. Not interning allws us to
circumvent the problem. */
ctop_string(CTXTc 4, output_buffer.string);
return(TRUE);
}
/* XSB regular expression matcher entry point
In:
Arg1: regexp
Arg2: string
Arg3: offset
Arg4: match_flags: Var means case-sensitive/extended;
number: ignorecase/extended
List: [{extended|ignorecase},...]
Out:
Arg5: list of the form [match(bo0,eo0), match(bo1,eo1),...]
where bo*,eo* specify the beginning and ending offsets of the
matched substrings.
All matched substrings are returned. Parenthesized expressions are
ignored.
*/
int do_bulkmatch__(void)
{
#ifdef MULTI_THREAD
if( NULL == th)
th = xsb_get_main_thread();
#endif
prolog_term listHead, listTail;
/* Prolog args are first assigned to these, so we could examine the types
of these objects to determine if we got strings or atoms. */
prolog_term regexp_term, input_term, offset_term;
prolog_term output_term = p2p_new(CTXT);
char *regexp_ptr=NULL; /* regular expression ptr */
char *input_string=NULL; /* string where matches are to be found */
int match_flags=FALSE;
int return_code, paren_number, offset;
regmatch_t *match_array;
int last_pos=0, input_len;
if (first_call)
initialize_regexp_tbl();
regexp_term = reg_term(CTXTc 1); /* Arg1: regexp */
if (is_string(regexp_term)) /* check it */
regexp_ptr = string_val(regexp_term);
else if (is_list(regexp_term))
regexp_ptr = p_charlist_to_c_string(CTXTc regexp_term, ®exp_buffer,
"RE_BULKMATCH", "regular expression");
else
xsb_abort("[RE_BULKMATCH] Arg 1 (the regular expression) must be an atom or a character list");
input_term = reg_term(CTXTc 2); /* Arg2: string to find matches in */
if (is_string(input_term)) /* check it */
input_string = string_val(input_term);
else if (is_list(input_term)) {
input_string = p_charlist_to_c_string(CTXTc input_term, &input_buffer,
"RE_BULKMATCH", "input string");
} else
xsb_abort("[RE_BULKMATCH] Arg 2 (the input string) must be an atom or a character list");
input_len = strlen(input_string);
offset_term = reg_term(CTXTc 3); /* arg3: offset within the string */
if (! is_int(offset_term))
xsb_abort("[RE_BULKMATCH] Arg 3 (the offset) must be an integer");
offset = int_val(offset_term);
if (offset < 0 || offset > input_len)
xsb_abort("[RE_BULKMATCH] Arg 3 (=%d) must be between 0 and %d", input_len);
/* arg 4 specifies flags: _, number, list [extended,ignorecase] */
match_flags = make_flags(reg_term(CTXTc 4), "RE_BULKMATCH");
last_pos = offset;
/* returned result */
listTail = output_term;
while (last_pos < input_len) {
return_code = xsb_re_match(regexp_ptr, input_string+last_pos, match_flags,
&match_array, &paren_number, "RE_BULKMATCH");
/* exit on no match */
if (! return_code) break;
c2p_list(CTXTc listTail); /* make it into a list */
listHead = p2p_car(listTail); /* get head of the list */
/* bind i-th match to listHead as match(beg,end) */
c2p_functor(CTXTc "match", 2, listHead);
c2p_int(CTXTc match_array[0].rm_so+last_pos, p2p_arg(listHead,1));
c2p_int(CTXTc match_array[0].rm_eo+last_pos, p2p_arg(listHead,2));
listTail = p2p_cdr(listTail);
if (match_array[0].rm_eo > 0)
last_pos = match_array[0].rm_eo+last_pos;
else
last_pos++;
}
c2p_nil(CTXTc listTail); /* bind tail to nil */
return p2p_unify(CTXTc output_term, reg_term(CTXTc 5));
}
DllExport int call_conv get_next_result(CTXTdecl)
{
if(head == NULL) return 0;
// process the head raptor-term and build a term
prolog_term return_term = reg_term(CTXTdecl 1);
prolog_term t = p2p_new();
c2p_functor(CTXTdecl prefix, 4, t);
c2p_raptor_term(CTXTdecl head->subject, p2p_arg(CTXTdecl t, 1));
c2p_raptor_term(CTXTdecl head->predicate, p2p_arg(CTXTdecl t, 2));
c2p_raptor_term(CTXTdecl head->object, p2p_arg(CTXTdecl t, 3));
c2p_raptor_term(CTXTdecl head->graph, p2p_arg(CTXTdecl t, 4));
p2p_unify(return_term, t);
// pop the head off the queue
struct raptor_node *old_head = head;
if(tail == head)
{
tail = NULL;
head = NULL;
}
else
head = head->prev;
// free up the strings
//printf("1");
if(old_head->subject.arg1 != NULL)
free(old_head->subject.arg1);
if(old_head->subject.arg2 != NULL)
free(old_head->subject.arg2);
if(old_head->subject.arg3 != NULL)
free(old_head->subject.arg3);
//printf("2");
if(old_head->predicate.arg1 != NULL)
free(old_head->predicate.arg1);
if(old_head->predicate.arg2 != NULL)
free(old_head->predicate.arg2);
if(old_head->predicate.arg3 != NULL)
free(old_head->predicate.arg3);
//printf("3");
if(old_head->object.arg1 != NULL)
free(old_head->object.arg1);
if(old_head->object.arg2 != NULL)
free(old_head->object.arg2);
if(old_head->object.arg3 != NULL)
free(old_head->object.arg3);
//printf("4");
if(old_head->graph.arg1 != NULL)
free(old_head->graph.arg1);
if(old_head->graph.arg2 != NULL)
free(old_head->graph.arg2);
if(old_head->graph.arg3 != NULL)
free(old_head->graph.arg3);
//printf("5");
free(old_head);
// return
return 1;
}
static void c2p_raptor_term(CTXTdecl struct raptor_node_item triple, prolog_term t)
{
switch(triple.type)
{
case RAPTOR_TERM_TYPE_UNKNOWN:
// printf("BUILD: (UKNOWN)" );
c2p_nil(CTXTdecl t);
break ;
case RAPTOR_TERM_TYPE_URI:
// printf("uri( %s )", raptor_uri_as_string(triple->value.uri));
c2p_functor(CTXTdecl "url", 1, t);
prolog_term uri_str = p2p_arg(CTXTdecl t, 1);
c2p_string(CTXTdecl (char *)triple.arg1, uri_str);
break ;
case RAPTOR_TERM_TYPE_LITERAL:
//printf("literal( %s, %s, %s )", triple->value.literal.string, raptor_uri_as_string(triple->value.literal.datatype), triple->value.literal.language);
c2p_functor(CTXTdecl "literal", 3, t);
// the actual string
prolog_term lit_str = p2p_arg(CTXTdecl t, 1);
c2p_string(CTXTdecl (char *)triple.arg1, lit_str);
// the datatype
prolog_term dt_str = p2p_arg(CTXTdecl t, 2);
if(triple.arg2 != NULL)
c2p_string(CTXTdecl (char *)triple.arg2, dt_str);
else
c2p_string(CTXTdecl "", dt_str);
// the language
prolog_term lang_str = p2p_arg(CTXTdecl t, 3);
if(triple.arg3 != NULL)
c2p_string(CTXTdecl (char *)triple.arg3, lang_str);
else
c2p_string(CTXTdecl "", lang_str);
break ;
case RAPTOR_TERM_TYPE_BLANK:
// printf("blank( %s )", triple->value.blank.string);
c2p_functor(CTXTdecl "blank", 1, t);
prolog_term blank_str = p2p_arg(CTXTdecl t, 1);
c2p_string(CTXTdecl (char *)triple.arg1, blank_str);
break ;
default:
c2p_nil(CTXTdecl t);
break ;
}
//return t;
}
DllExport int call_conv pl_load_page()
{
prolog_term head, tail, result = 0;
char *functor, *url = NULL, *data = NULL;
char *username = NULL, *password = NULL;
curl_opt options = init_options();
curl_ret ret_vals;
check_thread_context
tail = reg_term(CTXTc 1);
if(!is_list(tail))
return curl2pl_error(ERR_DOMAIN, "source", tail);
while(is_list(tail)){
head = p2p_car(tail);
tail = p2p_cdr(tail);
if(is_functor(head)){
functor = p2c_functor(head);
if(!strcmp(functor,"source")){
prolog_term term_url_func, term_url = 0;
term_url_func = p2p_arg(head, 1);
if(is_functor(term_url_func)){
if(!strcmp(p2c_functor(term_url_func), "url")){
term_url = p2p_arg(term_url_func, 1);
url = p2c_string(term_url);
data = load_page(url, options, &ret_vals);
}
else{
return curl2pl_error(ERR_MISC, "source", term_url);
}
}
else{
return curl2pl_error(ERR_MISC, "source", "Improper input format");
}
}
else if(!strcmp(functor,"options")){
prolog_term term_options = p2p_arg(head, 1);
prolog_term term_option;
while(is_list(term_options)){
term_option = p2p_car(term_options);
if(!strcmp(p2c_functor(term_option), "redirect")) {
if(!strcmp(p2c_string(p2p_arg(term_option, 1)), "true"))
options.redir_flag = 1;
else
options.redir_flag = 0;
}
else if(!strcmp(p2c_functor(term_option), "secure")){
if(!strcmp(p2c_string(p2p_arg(term_option, 1)), "false"))
options.secure.flag = 0;
else
options.secure.crt_name = p2c_string(p2p_arg(term_option, 1));
}
else if(!strcmp(p2c_functor(term_option), "auth")){
username = p2c_string(p2p_arg(term_option, 1));
password = p2c_string(p2p_arg(term_option, 2));
options.auth.usr_pwd = (char *) malloc ((strlen(username) + strlen(password) + 2) * sizeof(char));
strcpy(options.auth.usr_pwd, username);
strcat(options.auth.usr_pwd, ":");
strcat(options.auth.usr_pwd, password);
}
else if(!strcmp(p2c_functor(term_option), "timeout")){
options.timeout = (int)p2c_int(p2p_arg(term_option, 1));
}
else if(!strcmp(p2c_functor(term_option), "url_prop")){
options.url_prop = options.redir_flag;
}
else if(!strcmp(p2c_functor(term_option), "user_agent")){
options.user_agent = p2c_string(p2p_arg(term_option, 1));
}
else if(!strcmp(p2c_functor(term_option), "post")){
options.post_data = p2c_string(p2p_arg(term_option, 1));
}
term_options = p2p_cdr(term_options);
}
}
else if(!strcmp(functor,"document")){
result = p2p_arg(head, 1);
}
else if(!strcmp(functor,"properties")){
c2p_int(CTXTc (int) ret_vals.size, p2p_arg(head, 1));
/* the following code can be used to convert to local/UTC time, if
necessary. Note: XSB uses local time, and ret_vals.modify_time
is local, too.
struct tm * timeinfo;
timeinfo = gmtime(&(ret_vals.modify_time)); // UTC time
timeinfo = localtime(&(ret_vals.modify_time)); // local time
c2p_int(CTXTc (int) mktime(timeinfo), p2p_arg(head,2));
*/
/* return modification time as an integer */
c2p_int(CTXTc (int) ret_vals.modify_time, p2p_arg(head,2));
/*
The following converts time to string - not useful
if (ctime(&ret_vals.modify_time) == NULL)
c2p_string("", p2p_arg(head, 2));
else
c2p_string(CTXTc (char *) ctime(&ret_vals.modify_time),
p2p_arg(head, 2));
*/
}
}
else{
return curl2pl_error(ERR_DOMAIN, "source", head);
}
}
c2p_string(CTXTc data, result);
return TRUE;
}
/* TLS: making a conservative guess at which system calls need to be
mutexed. I'm doing it whenever I see the process table altered or
affected, so this is the data structure that its protecting.
At some point, the SET_FILEPTRs should be protected against other
threads closing that stream. Perhaps for such things a
thread-specific stream table should be used.
*/
xsbBool sys_system(CTXTdeclc int callno)
{
// int pid;
Integer pid;
switch (callno) {
case PLAIN_SYSTEM_CALL: /* dumb system call: no communication with XSB */
/* this call is superseded by shell and isn't used */
ctop_int(CTXTc 3, system(ptoc_string(CTXTc 2)));
return TRUE;
case SLEEP_FOR_SECS:
#ifdef WIN_NT
Sleep((int)iso_ptoc_int_arg(CTXTc 2,"sleep/1",1) * 1000);
#else
sleep(iso_ptoc_int_arg(CTXTc 2,"sleep/1",1));
#endif
return TRUE;
case GET_TMP_FILENAME:
ctop_string(CTXTc 2,tempnam(NULL,NULL));
return TRUE;
case IS_PLAIN_FILE:
case IS_DIRECTORY:
case STAT_FILE_TIME:
case STAT_FILE_SIZE:
return file_stat(CTXTc callno, ptoc_longstring(CTXTc 2));
case EXEC: {
#ifdef HAVE_EXECVP
/* execs a new process in place of XSB */
char *params[MAX_SUBPROC_PARAMS+2];
prolog_term cmdspec_term;
int index = 0;
cmdspec_term = reg_term(CTXTc 2);
if (islist(cmdspec_term)) {
prolog_term temp, head;
char *string_head=NULL;
if (isnil(cmdspec_term))
xsb_abort("[exec] Arg 1 must not be an empty list.");
temp = cmdspec_term;
do {
head = p2p_car(temp);
temp = p2p_cdr(temp);
if (isstring(head))
string_head = string_val(head);
else
xsb_abort("[exec] non-string argument passed in list.");
params[index++] = string_head;
if (index > MAX_SUBPROC_PARAMS)
xsb_abort("[exec] Too many arguments.");
} while (!isnil(temp));
params[index] = NULL;
} else if (isstring(cmdspec_term)) {
char *string = string_val(cmdspec_term);
split_command_arguments(string, params, "exec");
} else
xsb_abort("[exec] 1st argument should be term or list of strings.");
if (execvp(params[0], params))
xsb_abort("[exec] Exec call failed.");
#else
xsb_abort("[exec] builtin not supported in this architecture.");
#endif
}
case SHELL: /* smart system call: like SPAWN_PROCESS, but returns error code
instead of PID. Uses system() rather than execvp.
Advantage: can pass arbitrary shell command. */
case SPAWN_PROCESS: { /* spawn new process, reroute stdin/out/err to XSB */
/* +CallNo=2, +ProcAndArgsList,
-StreamToProc, -StreamFromProc, -StreamFromProcStderr,
-Pid */
static int pipe_to_proc[2], pipe_from_proc[2], pipe_from_stderr[2];
int toproc_stream=-1, fromproc_stream=-1, fromproc_stderr_stream=-1;
int pid_or_status;
FILE *toprocess_fptr=NULL,
*fromprocess_fptr=NULL, *fromproc_stderr_fptr=NULL;
char *params[MAX_SUBPROC_PARAMS+2]; /* one for progname--0th member,
one for NULL termination*/
prolog_term cmdspec_term, cmdlist_temp_term;
prolog_term cmd_or_arg_term;
xsbBool toproc_needed=FALSE, fromproc_needed=FALSE, fromstderr_needed=FALSE;
char *cmd_or_arg=NULL, *shell_cmd=NULL;
int idx = 0, tbl_pos;
char *callname=NULL;
xsbBool params_are_in_a_list=FALSE;
SYS_MUTEX_LOCK( MUTEX_SYS_SYSTEM );
init_process_table();
if (callno == SPAWN_PROCESS)
callname = "spawn_process/5";
else
callname = "shell/[1,2,5]";
cmdspec_term = reg_term(CTXTc 2);
if (islist(cmdspec_term))
params_are_in_a_list = TRUE;
else if (isstring(cmdspec_term))
shell_cmd = string_val(cmdspec_term);
else if (isref(cmdspec_term))
xsb_instantiation_error(CTXTc callname,1);
else
xsb_type_error(CTXTc "atom or list e.g. [command, arg, ...]",cmdspec_term,callname,1);
// xsb_abort("[%s] Arg 1 must be an atom or a list [command, arg, ...]",
// callname);
/* the user can indicate that he doesn't want either of the streams created
by putting an atom in the corresponding argument position */
if (isref(reg_term(CTXTc 3)))
toproc_needed = TRUE;
if (isref(reg_term(CTXTc 4)))
fromproc_needed = TRUE;
if (isref(reg_term(CTXTc 5)))
fromstderr_needed = TRUE;
/* if any of the arg streams is already used by XSB, then don't create
pipes --- use these streams instead. */
if (isointeger(reg_term(CTXTc 3))) {
SET_FILEPTR(toprocess_fptr, oint_val(reg_term(CTXTc 3)));
}
if (isointeger(reg_term(CTXTc 4))) {
SET_FILEPTR(fromprocess_fptr, oint_val(reg_term(CTXTc 4)));
}
if (isointeger(reg_term(CTXTc 5))) {
SET_FILEPTR(fromproc_stderr_fptr, oint_val(reg_term(CTXTc 5)));
}
if (!isref(reg_term(CTXTc 6)))
xsb_type_error(CTXTc "variable (to return process id)",reg_term(CTXTc 6),callname,5);
// xsb_abort("[%s] Arg 5 (process id) must be a variable", callname);
if (params_are_in_a_list) {
/* fill in the params[] array */
if (isnil(cmdspec_term))
xsb_abort("[%s] Arg 1 must not be an empty list", callname);
cmdlist_temp_term = cmdspec_term;
do {
cmd_or_arg_term = p2p_car(cmdlist_temp_term);
cmdlist_temp_term = p2p_cdr(cmdlist_temp_term);
if (isstring(cmd_or_arg_term)) {
cmd_or_arg = string_val(cmd_or_arg_term);
}
else
xsb_abort("[%s] Non string list member in the Arg",
callname);
params[idx++] = cmd_or_arg;
if (idx > MAX_SUBPROC_PARAMS)
xsb_abort("[%s] Too many arguments passed to subprocess",
callname);
} while (!isnil(cmdlist_temp_term));
params[idx] = NULL; /* null termination */
} else { /* params are in a string */
if (callno == SPAWN_PROCESS)
split_command_arguments(shell_cmd, params, callname);
else {
/* if callno==SHELL => call system() => don't split shell_cmd */
params[0] = shell_cmd;
params[1] = NULL;
}
}
/* -1 means: no space left */
if ((tbl_pos = get_free_process_cell()) < 0) {
xsb_warn(CTXTc "Can't create subprocess because XSB process table is full");
SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
return FALSE;
}
/* params[0] is the progname */
pid_or_status = xsb_spawn(CTXTc params[0], params, callno,
(toproc_needed ? pipe_to_proc : NULL),
(fromproc_needed ? pipe_from_proc : NULL),
(fromstderr_needed ? pipe_from_stderr : NULL),
toprocess_fptr, fromprocess_fptr,
fromproc_stderr_fptr);
if (pid_or_status < 0) {
xsb_warn(CTXTc "[%s] Subprocess creation failed, Error: %d, errno: %d, Cmd: %s", callname,pid_or_status,errno,params[0]);
SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
return FALSE;
}
if (toproc_needed) {
toprocess_fptr = fdopen(pipe_to_proc[1], "w");
toproc_stream = xsb_intern_fileptr(CTXTc toprocess_fptr,callname,"pipe","w",CURRENT_CHARSET);
ctop_int(CTXTc 3, toproc_stream);
}
if (fromproc_needed) {
fromprocess_fptr = fdopen(pipe_from_proc[0], "r");
fromproc_stream = xsb_intern_fileptr(CTXTc fromprocess_fptr,callname,"pipe","r",CURRENT_CHARSET);
ctop_int(CTXTc 4, fromproc_stream);
}
if (fromstderr_needed) {
fromproc_stderr_fptr = fdopen(pipe_from_stderr[0], "r");
fromproc_stderr_stream
= xsb_intern_fileptr(CTXTc fromproc_stderr_fptr,callname,"pipe","r",CURRENT_CHARSET);
ctop_int(CTXTc 5, fromproc_stderr_stream);
}
ctop_int(CTXTc 6, pid_or_status);
xsb_process_table.process[tbl_pos].pid = pid_or_status;
xsb_process_table.process[tbl_pos].to_stream = toproc_stream;
xsb_process_table.process[tbl_pos].from_stream = fromproc_stream;
xsb_process_table.process[tbl_pos].stderr_stream = fromproc_stderr_stream;
concat_array(CTXTc params, " ",
xsb_process_table.process[tbl_pos].cmdline,MAX_CMD_LEN);
SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
return TRUE;
}
case GET_PROCESS_TABLE: { /* sys_system(3, X). X is bound to the list
of the form [process(Pid,To,From,Stderr,Cmdline), ...] */
int i;
prolog_term table_term_tail, listHead;
prolog_term table_term=reg_term(CTXTc 2);
SYS_MUTEX_LOCK( MUTEX_SYS_SYSTEM );
init_process_table();
if (!isref(table_term))
xsb_abort("[GET_PROCESS_TABLE] Arg 1 must be a variable");
table_term_tail = table_term;
for (i=0; i<MAX_SUBPROC_NUMBER; i++) {
if (!FREE_PROC_TABLE_CELL(xsb_process_table.process[i].pid)) {
c2p_list(CTXTc table_term_tail); /* make it into a list */
listHead = p2p_car(table_term_tail);
c2p_functor(CTXTc "process", 5, listHead);
c2p_int(CTXTc xsb_process_table.process[i].pid, p2p_arg(listHead,1));
c2p_int(CTXTc xsb_process_table.process[i].to_stream, p2p_arg(listHead,2));
c2p_int(CTXTc xsb_process_table.process[i].from_stream, p2p_arg(listHead,3));
c2p_int(CTXTc xsb_process_table.process[i].stderr_stream,
p2p_arg(listHead,4));
c2p_string(CTXTc xsb_process_table.process[i].cmdline, p2p_arg(listHead,5));
table_term_tail = p2p_cdr(table_term_tail);
}
}
c2p_nil(CTXTc table_term_tail); /* bind tail to nil */
SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
return p2p_unify(CTXTc table_term, reg_term(CTXTc 2));
}
case PROCESS_STATUS: {
prolog_term pid_term=reg_term(CTXTc 2), status_term=reg_term(CTXTc 3);
SYS_MUTEX_LOCK( MUTEX_SYS_SYSTEM );
init_process_table();
if (!(isointeger(pid_term)))
xsb_abort("[PROCESS_STATUS] Arg 1 (process id) must be an integer");
pid = (int)oint_val(pid_term);
if (!isref(status_term))
xsb_abort("[PROCESS_STATUS] Arg 2 (process status) must be a variable");
switch (process_status(pid)) {
case RUNNING:
c2p_string(CTXTc "running", status_term);
break;
case STOPPED:
c2p_string(CTXTc "stopped", status_term);
break;
case EXITED_NORMALLY:
c2p_string(CTXTc "exited_normally", status_term);
break;
case EXITED_ABNORMALLY:
c2p_string(CTXTc "exited_abnormally", status_term);
break;
case ABORTED:
c2p_string(CTXTc "aborted", status_term);
break;
case INVALID:
c2p_string(CTXTc "invalid", status_term);
break;
default:
c2p_string(CTXTc "unknown", status_term);
}
SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
return TRUE;
}
case PROCESS_CONTROL: {
/* sys_system(PROCESS_CONTROL, +Pid, +Signal). Signal: wait, kill */
int status;
prolog_term pid_term=reg_term(CTXTc 2), signal_term=reg_term(CTXTc 3);
SYS_MUTEX_LOCK( MUTEX_SYS_SYSTEM );
init_process_table();
if (!(isointeger(pid_term)))
xsb_abort("[PROCESS_CONTROL] Arg 1 (process id) must be an integer");
pid = (int)oint_val(pid_term);
if (isstring(signal_term) && strcmp(string_val(signal_term), "kill")==0) {
if (KILL_FAILED(pid)) {
SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
return FALSE;
}
#ifdef WIN_NT
CloseHandle((HANDLE) pid);
#endif
SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
return TRUE;
}
if (isconstr(signal_term)
&& strcmp(p2c_functor(signal_term),"wait") == 0
&& p2c_arity(signal_term)==1) {
int exit_status;
if (WAIT(pid, status) < 0) {
SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
return FALSE;
}
#ifdef WIN_NT
exit_status = status;
#else
if (WIFEXITED(status))
exit_status = WEXITSTATUS(status);
else
exit_status = -1;
#endif
p2p_unify(CTXTc p2p_arg(signal_term,1), makeint(exit_status));
SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
return TRUE;
}
xsb_warn(CTXTc "[PROCESS_CONTROL] Arg 2: Invalid signal specification. Must be `kill' or `wait(Var)'");
return FALSE;
}
case LIST_DIRECTORY: {
/* assume all type- and mode-checking is done in Prolog */
prolog_term handle = reg_term(CTXTc 2); /* ref for handle */
char *dir_name = ptoc_longstring(CTXTc 3); /* +directory name */
prolog_term filename = reg_term(CTXTc 4); /* reference for name of file */
if (is_var(handle))
return xsb_find_first_file(CTXTc handle,dir_name,filename);
else
return xsb_find_next_file(CTXTc handle,dir_name,filename);
}
default:
xsb_abort("[SYS_SYSTEM] Wrong call number (an XSB bug)");
} /* end case */
return TRUE;
}
int convert_prObj_pyObj(prolog_term prTerm, PyObject **pyObj)
{
if(find_prolog_term_type(prTerm) == INT)
{
prolog_term argument = prTerm;
int argument_int = p2c_int(argument);
*pyObj = PyInt_FromLong(argument_int);
return TRUE;
}else if(find_prolog_term_type(prTerm) == STRING)
{
prolog_term argument = prTerm;
char *argument_char = p2c_string(argument);
*pyObj = PyString_FromString(argument_char);
return TRUE;
}else if(find_prolog_term_type(prTerm) == FLOAT)
{
prolog_term argument = prTerm;
float argument_float = p2c_float(argument);
*pyObj = PyFloat_FromDouble(argument_float);
return TRUE;
}
else if(find_prolog_term_type(prTerm) == LIST)
{
prolog_term argument = prTerm;
if(find_prolog_term_type(argument) == LIST)
{
int count = find_length_prolog_list(argument);
PyObject *pList = PyList_New(count);
if(!prlist2pyList(argument, pList, count))
return FALSE;
*pyObj = pList;
return TRUE;
}
}
// else if(find_prolog_term_type(prTerm) == REF)
// { //when a reference is passed.
// prolog_term argument = prTerm;
// char *argument_ref = p2c_string(argument);
// if(strncmp("ref_", argument_ref, 4)== 0 )
// { //gets the reference id from the string and finds it in the list
// argument_ref = argument_ref + 4;
// size_t ref = strtoul(argument_ref, NULL, 0);
// PyObject *obj = get_pyobj_ref_list(ref);
// if(obj == NULL)
// return FALSE;
// *pyObj = obj;
// return TRUE;
// }
// }
else if (find_prolog_term_type(prTerm) == FUNCTOR)
{
//region begin : handle pyobject term
if(strcmp(p2c_functor(prTerm),"pyObject") == 0)
{
prolog_term ref = p2p_arg(prTerm, 1);
char *node_pointer = p2c_string(ref);
pyobj_ref_node *pyobj_ref = (pyobj_ref_node *)strtol(node_pointer,NULL, 0);
//pyobj_ref_node *node = (pyobj_ref_node *)(node_pointer);
*pyObj = pyobj_ref->python_obj;
}
//end region
}
return FALSE;
}
/* XSB string substitution entry point: replace substrings specified in Arg2
with strings in Arg3.
In:
Arg1: string
Arg2: substring specification, a list [s(B1,E1),s(B2,E2),...]
Arg3: list of replacement strings
Out:
Arg4: new (output) string
Always succeeds, unless error.
*/
xsbBool string_substitute(CTXTdecl)
{
/* Prolog args are first assigned to these, so we could examine the types
of these objects to determine if we got strings or atoms. */
prolog_term input_term, output_term;
prolog_term subst_reg_term, subst_spec_list_term, subst_spec_list_term1;
prolog_term subst_str_term=(prolog_term)0,
subst_str_list_term, subst_str_list_term1;
char *input_string=NULL; /* string where matches are to be found */
char *subst_string=NULL;
prolog_term beg_term, end_term;
Integer beg_offset=0, end_offset=0, input_len;
Integer last_pos = 0; /* last scanned pos in input string */
/* the output buffer is made large enough to include the input string and the
substitution string. */
int conversion_required=FALSE; /* from C string to Prolog char list */
XSB_StrSet(&output_buffer,"");
input_term = reg_term(CTXTc 1); /* Arg1: string to find matches in */
if (isatom(input_term)) /* check it */
input_string = string_val(input_term);
else if (islist(input_term)) {
input_string = p_charlist_to_c_string(CTXTc input_term, &input_buffer,
"STRING_SUBSTITUTE", "input string");
conversion_required = TRUE;
} else
xsb_abort("[STRING_SUBSTITUTE] Arg 1 (the input string) must be an atom or a character list");
input_len = strlen(input_string);
/* arg 2: substring specification */
subst_spec_list_term = reg_term(CTXTc 2);
if (!islist(subst_spec_list_term) && !isnil(subst_spec_list_term))
xsb_abort("[STRING_SUBSTITUTE] Arg 2 must be a list [s(B1,E1),s(B2,E2),...]");
/* handle substitution string */
subst_str_list_term = reg_term(CTXTc 3);
if (! islist(subst_str_list_term))
xsb_abort("[STRING_SUBSTITUTE] Arg 3 must be a list of strings");
output_term = reg_term(CTXTc 4);
if (! isref(output_term))
xsb_abort("[STRING_SUBSTITUTE] Arg 4 (the output) must be an unbound variable");
subst_spec_list_term1 = subst_spec_list_term;
subst_str_list_term1 = subst_str_list_term;
if (isnil(subst_spec_list_term1)) {
XSB_StrSet(&output_buffer, input_string);
goto EXIT;
}
if (isnil(subst_str_list_term1))
xsb_abort("[STRING_SUBSTITUTE] Arg 3 must not be an empty list");
do {
subst_reg_term = p2p_car(subst_spec_list_term1);
subst_spec_list_term1 = p2p_cdr(subst_spec_list_term1);
if (!isnil(subst_str_list_term1)) {
subst_str_term = p2p_car(subst_str_list_term1);
subst_str_list_term1 = p2p_cdr(subst_str_list_term1);
if (isatom(subst_str_term)) {
subst_string = string_val(subst_str_term);
} else if (islist(subst_str_term)) {
subst_string = p_charlist_to_c_string(CTXTc subst_str_term, &subst_buf,
"STRING_SUBSTITUTE",
"substitution string");
} else
xsb_abort("[STRING_SUBSTITUTE] Arg 3 must be a list of strings");
}
beg_term = p2p_arg(subst_reg_term,1);
end_term = p2p_arg(subst_reg_term,2);
if (!(isointeger(beg_term)) ||
!(isointeger(end_term)))
xsb_abort("[STRING_SUBSTITUTE] Non-integer in Arg 2");
else {
beg_offset = oint_val(beg_term);
end_offset = oint_val(end_term);
}
/* -1 means end of string */
if (end_offset < 0)
end_offset = input_len;
if ((end_offset < beg_offset) || (beg_offset < last_pos))
xsb_abort("[STRING_SUBSTITUTE] Substitution regions in Arg 2 not sorted");
/* do the actual replacement */
XSB_StrAppendBlk(&output_buffer,input_string+last_pos,(int)(beg_offset-last_pos));
XSB_StrAppend(&output_buffer, subst_string);
last_pos = end_offset;
} while (!isnil(subst_spec_list_term1));
XSB_StrAppend(&output_buffer, input_string+end_offset);
EXIT:
/* get result out */
if (conversion_required)
c_string_to_p_charlist(CTXTc output_buffer.string, output_term,
4, "STRING_SUBSTITUTE", "Arg 4");
else
c2p_string(CTXTc output_buffer.string, output_term);
return(TRUE);
}
int main(int argc, char *argv[])
{
int rcode;
int myargc = 3;
char *myargv[3];
/* xsb_init relies on the calling program to pass the absolute or relative
path name of the XSB installation directory. We assume that the current
program is sitting in the directory .../examples/c_calling_xsb/
To get installation directory, we strip 3 file names from the path. */
myargv[0] = strip_names_from_path(xsb_executable_full_path(argv[0]), 3);
myargv[1] = "-n";
myargv[2] = "-e writeln(hello). writeln(kkk).";
/* Initialize xsb */
xsb_init(myargc,myargv); /* depend on user to put in right options (-n) */
/* Create command to consult a file: ctest.P, and send it. */
c2p_functor("consult",1,reg_term(1));
c2p_string("ctest",p2p_arg(reg_term(1),1));
if (xsb_command()) {
printf("Error consulting ctest.P.\n");
fflush(stdout);
}
if (xsb_command_string("consult(basics).")) {
printf("Error (string) consulting basics.\n");
fflush(stdout);
}
/* Create the query p(300,X,Y) and send it. */
c2p_functor("p",3,reg_term(1));
c2p_int(300,p2p_arg(reg_term(1),1));
rcode = xsb_query();
/* Print out answer and retrieve next one. */
while (!rcode) {
if (!(is_string(p2p_arg(reg_term(2),1)) &
is_string(p2p_arg(reg_term(2),2))))
printf("2nd and 3rd subfields must be atoms\n");
else
printf("Answer: %d, %s(%s), %s(%s)\n",
p2c_int(p2p_arg(reg_term(1),1)),
p2c_string(p2p_arg(reg_term(1),2)),
xsb_var_string(1),
p2c_string(p2p_arg(reg_term(1),3)),
xsb_var_string(2)
);
fflush(stdout);
rcode = xsb_next();
}
/* Create the string query p(300,X,Y) and send it, use higher-level
routines. */
xsb_make_vars(3);
xsb_set_var_int(300,1);
rcode = xsb_query_string("p(X,Y,Z).");
/* Print out answer and retrieve next one. */
while (!rcode) {
if (!(is_string(p2p_arg(reg_term(2),2)) &
is_string(p2p_arg(reg_term(2),3))))
printf("2nd and 3rd subfields must be atoms\n");
else
printf("Answer: %d, %s, %s\n",
xsb_var_int(1),
xsb_var_string(2),
xsb_var_string(3)
);
fflush(stdout);
rcode = xsb_next();
}
/* Close connection */
xsb_close();
printf("cmain exit\n");
return(0);
}
