/* 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;
}
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;
}
/* 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;
}
/* 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: next_valid_timestamp(Ts1,Ts2,Interval,NTs)
* Returns NTs as the next valid timestamp after Ts2 taking into account the
* interval. This is useful for the periodics events
*/
int next_valid_timestamp(CTXTdecl)
{
int ts = p2c_int(reg_term(CTXTc 1));
int interval = p2c_int(reg_term(CTXTc 3));
int ts_now = p2c_int(reg_term(CTXTc 2));
int next_ts = 0;
if (ts_now <= ts)
{
next_ts = ts + interval;
c2p_int(CTXTc next_ts, reg_term(CTXTc 4));
return TRUE;
}
int diff = (ts_now - ts);
int left_time = diff % interval;
next_ts = ts_now + (interval - left_time);
c2p_int(CTXTc next_ts, reg_term(CTXTc 4));
return TRUE;
}
/*
* 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;
}
static xsbBool set_error_code(CTXTdeclc int ErrCode, int ErrCodeArgNumber, char *Where)
{
prolog_term ecode_value_term, ecode_arg_term = p2p_new(CTXT);
ecode_value_term = reg_term(CTXTc ErrCodeArgNumber);
if (!isref(ecode_value_term) &&
!(isointeger(ecode_value_term)))
xsb_abort("[%s] Arg %d (the error code) must be a variable or an integer!",
Where, ErrCodeArgNumber);
c2p_int(CTXTc ErrCode, ecode_arg_term);
return p2p_unify(CTXTc ecode_arg_term, ecode_value_term);
}
/*
* call as: epoch(+Y,+M,+D,+H,+M,+S,-Sec)
* Returns the seconds until the date Y-M-D-H-M-S
*/
int epoch(CTXTdecl)
{
int time_sec;
struct tm time;
time.tm_year = p2c_int(reg_term(CTXTc 1)) - 1900;
time.tm_mon = p2c_int(reg_term(CTXTc 2)) - 1 ;
time.tm_mday = p2c_int(reg_term(CTXTc 3));
time.tm_hour = p2c_int(reg_term(CTXTc 4));
time.tm_min = p2c_int(reg_term(CTXTc 5));
time.tm_sec = p2c_int(reg_term(CTXTc 6));
time.tm_isdst = -1;
time_sec = mktime(&time);
c2p_int(CTXTc time_sec, reg_term(CTXTc 7));
return TRUE;
}
/* utility function to return the available socket descriptors after testing */
static void test_ready(CTXTdeclc prolog_term *avail_sockfds, fd_set *fdset,
int *fds, int size)
{
prolog_term head;
int i=0;
for (i=0;i<size;i++) {
c2p_list(CTXTc *avail_sockfds);
if (FD_ISSET(fds[i], fdset)) {
head = p2p_car(*avail_sockfds);
c2p_int(CTXTc fds[i], head);
*avail_sockfds = p2p_cdr(*avail_sockfds);
}
}
c2p_nil(CTXTc *avail_sockfds);
return;
}
int epoch2date(CTXTdecl)
{
time_t epoch = p2c_int(reg_term(CTXTc 7));
struct tm date = *localtime(&epoch);
c2p_int(CTXTc 1900 + date.tm_year, reg_term(CTXTc 1));
c2p_int(CTXTc 1 + date.tm_mon, reg_term(CTXTc 2));
c2p_int(CTXTc date.tm_mday, reg_term(CTXTc 3));
c2p_int(CTXTc date.tm_hour, reg_term(CTXTc 4));
c2p_int(CTXTc date.tm_min, reg_term(CTXTc 5));
c2p_int(CTXTc date.tm_sec, reg_term(CTXTc 6));
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;
}
/* 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_pyObj_prObj(PyObject *pyObj, prolog_term *prTerm)
{
if(pyObj == Py_None){
return 1;// todo: check this case for a list with a none in the list. how does prolog side react
}
if(PyInt_Check(pyObj))
{
int result = PyInt_AS_LONG(pyObj);
//extern_ctop_int(3, result);
c2p_int(result, *prTerm);
return 1;
}
else if(PyFloat_Check(pyObj))
{
float result = PyFloat_AS_DOUBLE(pyObj);
//extern_ctop_float(3, result);
c2p_float(result, *prTerm);
return 1;
}else if(PyString_Check(pyObj))
{
char *result = PyString_AS_STRING(pyObj);
//extern_ctop_string(3, result);
c2p_string(result, *prTerm);
return 1;
}else if(PyList_Check(pyObj))
{
size_t size = PyList_Size(pyObj);
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 *pyObjInner = PyList_GetItem(pyObj, i);
//int temp = PyInt_AS_LONG(pyObj);
//c2p_int(temp, head);
convert_pyObj_prObj(pyObjInner, &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(pyObj);
//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, *prTerm);
return 1;
}
}
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;
}
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);
}
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;
}
/* 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));
}
/**
* Function to handle the errors. It creates an appropriate error term
* for the prolog side to throw.
* Input : type of error
* Output : TRUE on success, FALSE on failure
**/
int
sgml2pl_error(plerrorid id, ...)
{
prolog_term except = p2p_new();
prolog_term formal = p2p_new();
prolog_term swi = p2p_new();
prolog_term tmp1 = p2p_new();
prolog_term tmp;
va_list args;
char msgbuf[1024];
char *msg = NULL;
va_start(args, id);
/*Create the appropriate error term based on the type of error*/
switch(id)
{
case ERR_ERRNO: /*Standard unix errors*/
{
int err = va_arg(args, int);
msg = strerror(err);
switch(err)
{
/*Not enough memory error*/
case ENOMEM:
c2p_functor("sgml", 1, tmp1);
tmp = p2p_arg( tmp1, 1);
c2p_functor( "resource_error", 1, tmp);
c2p_string( "no_memory", p2p_arg( tmp, 1));
p2p_unify( tmp1, formal);
break;
/*No access error*/
case EACCES:
{
const char *file = va_arg(args, const char *);
const char *action = va_arg(args, const char *);
c2p_functor("sgml", 1, tmp1);
tmp = p2p_arg( tmp1, 1);
c2p_functor( "permission_error", 3, tmp);
c2p_string( (char*)action, p2p_arg(tmp, 1));
c2p_string( "file", p2p_arg(tmp, 2));
c2p_string ( (char*)file, p2p_arg(tmp, 3));
p2p_unify( tmp1, formal);
break;
}
/*Entity not found error*/
case ENOENT:
{
const char *file = va_arg(args, const char *);
c2p_functor("sgml", 1, tmp1);
tmp = p2p_arg( tmp1, 1);
c2p_functor( "permission_error", 2, tmp);
c2p_string( "file", p2p_arg(tmp, 1));
c2p_string ( (char*)file, p2p_arg(tmp, 2));
p2p_unify( tmp1, formal);
break;
}
/*Defaults to system error*/
default:
{
c2p_functor("sgml", 1, tmp1);
tmp = p2p_arg( tmp1, 1);
c2p_string("system_error", tmp);
p2p_unify( tmp1, formal);
break;
}
}
break;
}
case ERR_TYPE:
{
const char *expected = va_arg(args, const char*);
prolog_term actual = va_arg(args, prolog_term);
/*Type error*/
c2p_functor("sgml", 1, tmp1);
tmp = p2p_arg( tmp1, 1);
if( is_attv( actual) && strcmp(expected, "variable") != 0 )
{
c2p_string( "instantiation_error", tmp);
p2p_unify( tmp1, formal);
}
else
{
c2p_functor( "type_error", 2, tmp);
c2p_string( (char*)expected, p2p_arg(tmp, 1));
p2p_unify ( actual, p2p_arg(tmp, 2));
p2p_unify( tmp1, formal);
}
break;
}
case ERR_DOMAIN: /*Domain error*/
{
const char *expected = va_arg(args, const char*);
prolog_term actual = va_arg(args, prolog_term);
/*Improper domain of functor*/
c2p_functor("sgml", 1, tmp1);
tmp = p2p_arg( tmp1, 1);
if( is_attv( actual) && strcmp(expected, "variable") != 0 )
{
c2p_string( "instantiation_error", tmp);
p2p_unify( tmp1, formal);
}
else
{
c2p_functor( "domain_error", 2, tmp);
c2p_string( (char*)expected, p2p_arg(tmp, 1));
p2p_unify( actual, p2p_arg(tmp, 2));
p2p_unify( tmp1, formal);
}
break;
}
case ERR_EXISTENCE: /*Existence error*/
{
const char *type = va_arg(args, const char *);
prolog_term obj = va_arg(args, prolog_term);
/*Resource not found*/
c2p_functor("sgml", 1, tmp1);
tmp = p2p_arg( tmp1, 1);
c2p_functor( "existence_error", 2, tmp);
c2p_string( (char*)type, p2p_arg(tmp, 1));
p2p_unify ( obj, p2p_arg(tmp, 2));
p2p_unify( tmp1, formal);
break;
}
case ERR_FAIL:
{
/*Goal failed error*/
prolog_term goal = va_arg(args, prolog_term);
c2p_functor("sgml", 1, tmp1);
tmp = p2p_arg( tmp1, 1);
c2p_functor( "goal_failed", 1, tmp);
p2p_unify( p2p_arg( tmp,1), goal);
p2p_unify( tmp1, formal);
break;
}
case ERR_LIMIT:
{
/*Limit exceeded error*/
const char *limit = va_arg(args, const char *);
long maxval = va_arg(args, long);
c2p_functor("sgml", 1, tmp1);
tmp = p2p_arg( tmp1, 1);
c2p_functor( "limit_exceeded", 2, tmp);
c2p_string( (char*)limit, p2p_arg( tmp,1));
c2p_int( maxval, p2p_arg( tmp, 2));
p2p_unify( tmp1, formal);
break;
}
case ERR_MISC:
{
/*Miscellaneous error*/
const char *id = va_arg(args, const char *);
const char *fmt = va_arg(args, const char *);
vsprintf(msgbuf, fmt, args);
msg = msgbuf;
c2p_functor("sgml", 1, tmp1);
tmp = p2p_arg( tmp1, 1);
c2p_functor( "miscellaneous", 1, tmp);
c2p_string( (char*)id, p2p_arg( tmp, 1));
p2p_unify( tmp1, formal);
break;
}
default:
assert(0);
}
va_end(args);
if ( msg )
{
prolog_term msgterm = p2p_new();
if ( msg )
{
c2p_string( msg, msgterm);
}
tmp = p2p_new();
c2p_functor( "context", 1, tmp);
p2p_unify( p2p_arg( tmp, 1), msgterm);
p2p_unify( tmp, swi);
}
/*Create the error term to throw*/
tmp = p2p_new();
c2p_functor( "error", 2, tmp);
p2p_unify( p2p_arg( tmp, 1), formal);
p2p_unify( p2p_arg( tmp, 2), swi);
p2p_unify( tmp, except);
return p2p_unify( global_error_term, except);
}