/* Check if PATH exists. Create if it doesn't. Bark if it can't create or if
PATH exists, but isn't a directory. */
static void check_create_dir(char *path) {
struct stat *fileinfo = mem_alloc(1*sizeof(struct stat),LEAK_SPACE);
int retcode = stat(path, fileinfo);
if (!fileinfo) {
xsb_abort("No core memory to allocate stat structure.\n");
}
if (retcode == 0 && ! S_ISDIR(fileinfo->st_mode)) {
xsb_warn("File `%s' is not a directory!\n XSB uses this directory to store data.", path);
/* exit(1); */
}
if (retcode != 0)
#ifdef WIN_NT
retcode = mkdir(path);
#else
retcode = mkdir(path, 0755);
#endif
if (retcode != 0) {
xsb_warn("Cannot create directory `%s'!\n XSB uses this directory to store data.", path);
/* exit(1); */
}
mem_dealloc(fileinfo,1*sizeof(struct stat),LEAK_SPACE);
}
HashStats hash_statistics(CTXTdeclc Structure_Manager *sm) {
HashStats ht_stats;
counter num_used_hdrs;
BTHTptr pBTHT;
BTNptr *ppBTN;
ht_stats.hdr = node_statistics(sm);
num_used_hdrs = 0;
HashStats_NumBuckets(ht_stats) = 0;
HashStats_TotalOccupancy(ht_stats) = 0;
HashStats_NonEmptyBuckets(ht_stats) = 0;
HashStats_BucketSize(ht_stats) = sizeof(void *);
pBTHT = (BTHTptr)SM_AllocList(*sm);
while ( IsNonNULL(pBTHT) ) {
#ifdef DEBUG_ASSERTIONS
/* Counter for contents of current hash table
------------------------------------------ */
v counter num_contents = 0;
#endif
num_used_hdrs++;
HashStats_NumBuckets(ht_stats) += BTHT_NumBuckets(pBTHT);
HashStats_TotalOccupancy(ht_stats) += BTHT_NumContents(pBTHT);
for ( ppBTN = BTHT_BucketArray(pBTHT);
ppBTN < BTHT_BucketArray(pBTHT) + BTHT_NumBuckets(pBTHT);
ppBTN++ )
if ( IsNonNULL(*ppBTN) ) {
#ifdef DEBUG_ASSERTIONS
/* Count the objects in each bucket
-------------------------------- */
BTNptr pBTN = *ppBTN;
do {
num_contents++;
pBTN = BTN_Sibling(pBTN);
} while ( IsNonNULL(pBTN) );
#endif
HashStats_NonEmptyBuckets(ht_stats)++;
}
#ifdef DEBUG_ASSERTIONS
/* Compare counter and header values
--------------------------------- */
if ( num_contents != BTHT_NumContents(pBTHT) )
xsb_warn(CTXTc "Inconsistent %s Usage Calculations:\n"
"\tHash table occupancy mismatch.", SM_StructName(*sm));
#endif
pBTHT = BTHT_NextBTHT(pBTHT);
}
if ( HashStats_NumAllocHeaders(ht_stats) !=
(num_used_hdrs + HashStats_NumFreeHeaders(ht_stats)) )
xsb_warn(CTXTc "Inconsistent %s Usage Calculations:\n"
"\tHeader count mismatch: Alloc: %d Used: %d Free: %d",
SM_StructName(*sm), HashStats_NumAllocHeaders(ht_stats),
num_used_hdrs, HashStats_NumFreeHeaders(ht_stats));
return ht_stats;
}
int get_match_resultC__( void ) {
int order;
#ifdef MULTI_THREAD
if( NULL == th)
th = xsb_get_main_thread();
#endif
int submatch_number=ptoc_int(CTXTc 1);
/*--------------------------------------------------------------------------
Convert from Prolog-side convention for refering to submatches to
the corresponding array index numbers in match result storage.
--------------------------------------------------------------------------*/
switch (submatch_number) {
case MATCH: /*MATCH = -1*/
order = 0; /* actual position in the memory */
break;
case PREMATCH: /*PREMATCH = -2*/
order = 1;
break;
case POSTMATCH: /*POSTMATCH = -3*/
order = 2;
break;
case LAST_PAREN_MATCH: /*LAST_PAREN_MATCH = -4*/
order = 3;
break;
default:
if ( submatch_number > MAX_SUB_MATCH ) {
char message[120];
sprintf(message,
"Specified submatch number %d exceeds the limit: %d\n",
submatch_number, MAX_SUB_MATCH);
xsb_warn(message);
order = -99;
}
else order = submatch_number+3; /* actual position in the memory */
break;
}
if (order == -99) return(FAILURE);
if ( matchPattern == NULL ) { /*didn't try_match before*/
xsb_warn("Call try_match/2 first!");
return(FAILURE);
} else if ( !strcmp(matchResults[order],"") || matchResults[order] == NULL )
return(FAILURE); /*no match found, return FAILURE */
else {
c2p_string(CTXTc matchResults[order], reg_term(CTXTc 2));
return(SUCCESS);
}
}
void set_xsbinfo_dir () {
struct stat *fileinfo = mem_alloc(1*sizeof(struct stat),LEAK_SPACE);
char old_xinitrc[MAXPATHLEN], new_xinitrc[MAXPATHLEN],
user_config_dir[MAXPATHLEN], user_arch_dir[MAXPATHLEN];
int retcode;
if (!fileinfo) {
xsb_abort("No core memory to allocate stat structure.\n");
}
snprintf(xsbinfo_dir_gl, MAXPATHLEN, "%s%c.xsb", user_home_gl, SLASH);
snprintf(old_xinitrc, MAXPATHLEN, "%s%c.xsbrc", user_home_gl, SLASH);
snprintf(new_xinitrc, MAXPATHLEN, "%s%cxsbrc", xsbinfo_dir_gl, SLASH);
snprintf(user_config_dir, MAXPATHLEN, "%s%cconfig", xsbinfo_dir_gl, SLASH);
snprintf(user_arch_dir, MAXPATHLEN, "%s%c%s", user_config_dir, SLASH, FULL_CONFIG_NAME);
/* Create USER_HOME/.xsb directory, if it doesn't exist. */
check_create_dir(xsbinfo_dir_gl);
check_create_dir(user_config_dir);
check_create_dir(user_arch_dir);
retcode = stat(old_xinitrc, fileinfo);
if ((retcode == 0) && (stat(new_xinitrc, fileinfo) != 0)) {
xsb_warn("It appears that you have an old-style `.xsbrc' file!\n The XSB initialization file is now %s.\n If your `.xinitrc' defines the `library_directory' predicate,\n please consult the XSB manual for the new conventions.", new_xinitrc);
}
mem_dealloc(fileinfo,1*sizeof(struct stat),LEAK_SPACE);
}
Pair link_sym(Psc psc, Psc mod_psc)
{
Pair *search_ptr, found_pair;
char *name, message[120];
byte arity, global_flag;
name = get_name(psc);
arity = get_arity(psc);
if ( (global_flag = is_globalmod(mod_psc)) )
search_ptr = (Pair *)symbol_table.table +
hash(name, arity, symbol_table.size);
else
search_ptr = (Pair *)&get_data(mod_psc);
if ((found_pair = search(arity, name, search_ptr))) {
if (pair_psc(found_pair) != psc) {
/*
* Invalidate the old name!! It is no longer accessible
* through the global chain.
*/
if ( get_type(pair_psc(found_pair)) != T_ORDI ) {
sprintf(message,
"%s/%d (type %d) was defined in another module!",
name, arity, get_type(pair_psc(found_pair)));
xsb_warn(message);
}
pair_psc(found_pair) = psc;
}
}
else {
found_pair = make_psc_pair(psc, search_ptr);
if (global_flag)
symbol_table_increment_and_check_for_overflow;
}
return found_pair;
} /* link_sym */
/* 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;
}
/*
For a callnode call1 returns a Prolog list of callnode on which call1
immediately depends.
*/
int immediate_inedges_list(CTXTdeclc callnodeptr call1){
VariantSF subgoal;
TIFptr tif;
int j, count = 0,arity;
Psc psc;
CPtr oldhreg = NULL;
calllistptr cl;
reg[4] = makelist(hreg);
new_heap_free(hreg);
new_heap_free(hreg);
if(IsNonNULL(call1)){ /* This can be called from some non incremental predicate */
cl= call1->inedges;
while(IsNonNULL(cl)){
subgoal = (VariantSF) cl->inedge_node->callnode->goal;
if(IsNonNULL(subgoal)){/* fact check */
count++;
tif = (TIFptr) subgoal->tif_ptr;
psc = TIF_PSC(tif);
arity = get_arity(psc);
check_glstack_overflow(4,pcreg,2+arity*200); // don't know how much for build_subgoal_args...
oldhreg = hreg-2;
if(arity>0){
sreg = hreg;
follow(oldhreg++) = makecs(hreg);
hreg += arity + 1;
new_heap_functor(sreg, psc);
for (j = 1; j <= arity; j++) {
new_heap_free(sreg);
cell_array1[arity-j] = cell(sreg-1);
}
build_subgoal_args(subgoal);
}else{
follow(oldhreg++) = makestring(get_name(psc));
}
follow(oldhreg) = makelist(hreg);
new_heap_free(hreg);
new_heap_free(hreg);
}
cl=cl->next;
}
if (count>0)
follow(oldhreg) = makenil;
else
reg[4] = makenil;
}else{
xsb_warn("Called with non-incremental predicate\n");
reg[4] = makenil;
}
return unify(CTXTc reg_term(CTXTc 3),reg_term(CTXTc 4));
}
void set_psc_ep_to_psc(Psc psc_to_set, Psc target_psc) {
if (get_arity(psc_to_set) != get_arity(target_psc)) {
xsb_abort("[IMPORT AS] Cannot import predicate as a predicate with a different arity: %s/%d\n",
get_name(psc_to_set),get_arity(psc_to_set));
} else if (get_ep(psc_to_set) != (byte *)&(psc_to_set->load_inst) &&
get_ep(psc_to_set) != (byte *)&(target_psc->load_inst)) {
xsb_warn("[IMPORT AS] Redefining entry to import-as predicate: %s/%d\n",
get_name(psc_to_set),get_arity(psc_to_set));
set_ep(psc_to_set,(byte *)&(target_psc->load_inst));
} else {
set_ep(psc_to_set,(byte *)&(target_psc->load_inst));
}
}
Pair link_sym(Psc psc, Psc mod_psc)
{
Pair *search_ptr, found_pair;
char *name;
byte arity, global_flag, type;
SYS_MUTEX_LOCK_NOERROR( MUTEX_SYMBOL ) ;
name = get_name(psc);
arity = get_arity(psc);
if ( (global_flag = is_globalmod(mod_psc)) ) {
search_ptr = (Pair *)symbol_table.table +
hash(name, arity, symbol_table.size);
} else
search_ptr = (Pair *)&get_data(mod_psc);
if ((found_pair = search(arity, name, search_ptr))) {
if (pair_psc(found_pair) != psc) {
/*
* Invalidate the old name!! It is no longer accessible
* through the global chain.
*/
type = get_type(pair_psc(found_pair));
if ( type != T_ORDI ) {
char message[220], modmsg[200];
if (type == T_DYNA || type == T_PRED) {
Psc mod_psc;
mod_psc = (Psc) get_data(pair_psc(found_pair));
if (mod_psc == 0) snprintf(modmsg,200,"%s","usermod");
else if (isstring(mod_psc)) snprintf(modmsg,200,"usermod from file: %s",string_val(mod_psc));
else snprintf(modmsg,200,"module: %s",get_name(mod_psc));
snprintf(message,220,
"%s/%d (type %d) had been defined in %s",
name, arity, type,
modmsg);
} else
snprintf(message,220,
"%s/%d (type %d) had been defined in another module!",
name, arity, type);
xsb_warn(message);
}
pair_psc(found_pair) = psc;
}
}
else {
found_pair = make_psc_pair(psc, search_ptr);
if (global_flag)
symbol_table_increment_and_check_for_overflow;
}
SYS_MUTEX_UNLOCK_NOERROR( MUTEX_SYMBOL ) ;
return found_pair;
} /* link_sym */
NodeStats subgoal_statistics(CTXTdeclc Structure_Manager *sm) {
NodeStats sg_stats;
TIFptr tif;
int nSubgoals;
VariantSF pProdSF;
SubConsSF pConsSF;
sg_stats = node_statistics(sm);
nSubgoals = 0;
SYS_MUTEX_LOCK( MUTEX_TABLE );
if ( sm == &smVarSF ) {
for ( tif = tif_list.first; IsNonNULL(tif); tif = TIF_NextTIF(tif) )
if ( IsVariantPredicate(tif) )
for ( pProdSF = TIF_Subgoals(tif); IsNonNULL(pProdSF);
pProdSF = (VariantSF)subg_next_subgoal(pProdSF) )
nSubgoals++;
}
/* No shared smProdSF or smConsSF in MT engine */
else if ( sm == &smProdSF ) {
for ( tif = tif_list.first; IsNonNULL(tif); tif = TIF_NextTIF(tif) )
if ( IsSubsumptivePredicate(tif) )
for ( pProdSF = TIF_Subgoals(tif); IsNonNULL(pProdSF);
pProdSF = (VariantSF)subg_next_subgoal(pProdSF) )
nSubgoals++;
}
else if ( sm == &smConsSF ) {
for ( tif = tif_list.first; IsNonNULL(tif); tif = TIF_NextTIF(tif) )
if ( IsSubsumptivePredicate(tif) )
for ( pProdSF = TIF_Subgoals(tif); IsNonNULL(pProdSF);
pProdSF = (VariantSF)subg_next_subgoal(pProdSF) )
for ( pConsSF = subg_consumers(pProdSF); IsNonNULL(pConsSF);
pConsSF = conssf_consumers(pConsSF) )
nSubgoals++;
}
else {
SYS_MUTEX_UNLOCK( MUTEX_TABLE );
xsb_dbgmsg((LOG_DEBUG, "Incorrect use of subgoal_statistics()\n"
"SM does not contain subgoal frames"));
return sg_stats;
}
SYS_MUTEX_UNLOCK( MUTEX_TABLE );
if ( NodeStats_NumUsedNodes(sg_stats) != (counter) nSubgoals )
xsb_warn(CTXTc "Inconsistent Subgoal Frame Usage Calculations:\n"
"\tSubgoal Frame count mismatch");
return sg_stats;
}
/*----------------------------------------------------------------------------
next_match__()
The pattern match function which repeats pattern match after
the pattern match of the function try_match__().
If there is no calling of function try_match__() before, give warning!
output: if no match found, return FAILURE.
----------------------------------------------------------------------------*/
int next_match__( void )
{
int was_match; /* return code */
if ( matchPattern == NULL ) { /*didn't try_match__ before*/
xsb_warn("call try_match/2 first!");
was_match = FAILURE;
}
else /*do next match*/
was_match = match_again( );
if (global_pattern_mode)
return(was_match);
/* always fail, if Perl pattern is not global */
return FAILURE;
}
/* Our separate thread */
void checkJavaInterrupt(void *info)
{
char ch;
SOCKET intSocket = (SOCKET)info;
xsb_dbgmsg((LOG_DEBUG, "Thread started on socket %ld",(int)intSocket));
while(1){
if (1!=recv(intSocket,&ch,1,0)) {
xsb_warn("Problem handling interrupt from Java");
}
else
xsb_mesg("--- Java interrupt detected");
/* Avoid those annoying lags? */
fflush(stdout);
fflush(stderr);
fflush(stdmsg);
fflush(stdwarn);
fflush(stddbg);
keyint_proc(SIGINT); /* Do XSB's "interrupt" thing */
}
}
/*----------------------------------------------------------------------------
next_match__()
The pattern match function which repeats pattern match after
the pattern match of the function try_match__().
If there is no calling of function try_match__() before, give warning!
output: if no match found, return FAILURE.
----------------------------------------------------------------------------*/
int next_match__( void )
{
int was_match; /* return code */
#ifdef MULTI_THREAD
if( NULL == th)
th = xsb_get_main_thread();
#endif
if ( matchPattern == NULL ) { /*didn't try_match__ before*/
xsb_warn("call try_match/2 first!");
was_match = FAILURE;
}
else /*do next match*/
was_match = match_again( );
if (global_pattern_mode)
return(was_match);
/* always fail, if Perl pattern is not global */
return FAILURE;
}
int immediate_outedges_list(CTXTdeclc callnodeptr call1){
VariantSF subgoal;
TIFptr tif;
int j, count = 0,arity;
Psc psc;
CPtr oldhreg = NULL;
struct hashtable *h;
struct hashtable_itr *itr;
callnodeptr cn;
reg[4] = makelist(hreg);
new_heap_free(hreg);
new_heap_free(hreg);
if(IsNonNULL(call1)){ /* This can be called from some non incremental predicate */
h=call1->outedges->hasht;
itr = hashtable1_iterator(h);
if (hashtable1_count(h) > 0){
do {
cn = hashtable1_iterator_value(itr);
if(IsNonNULL(cn->goal)){
count++;
subgoal = (VariantSF) cn->goal;
tif = (TIFptr) subgoal->tif_ptr;
psc = TIF_PSC(tif);
arity = get_arity(psc);
check_glstack_overflow(4,pcreg,2+arity*200); // don't know how much for build_subgoal_args...
oldhreg=hreg-2;
if(arity>0){
sreg = hreg;
follow(oldhreg++) = makecs(sreg);
hreg += arity + 1;
new_heap_functor(sreg, psc);
for (j = 1; j <= arity; j++) {
new_heap_free(sreg);
cell_array1[arity-j] = cell(sreg-1);
}
build_subgoal_args(subgoal);
}else{
follow(oldhreg++) = makestring(get_name(psc));
}
follow(oldhreg) = makelist(hreg);
new_heap_free(hreg);
new_heap_free(hreg);
}
} while (hashtable1_iterator_advance(itr));
}
if (count>0)
follow(oldhreg) = makenil;
else
reg[4] = makenil;
}else{
xsb_warn("Called with non-incremental predicate\n");
reg[4] = makenil;
}
// printterm(stdout,call_list,100);
return unify(CTXTc reg_term(CTXTc 3),reg_term(CTXTc 4));
}
int create_lazy_call_list(CTXTdeclc callnodeptr call1){
VariantSF subgoal;
TIFptr tif;
int j,count=0,arity;
Psc psc;
CPtr oldhreg=NULL;
// print_call_list(lazy_affected);
reg[6] = reg[5] = makelist(hreg); // reg 5 first not-used, use regs in case of stack expanson
new_heap_free(hreg); // make heap consistent
new_heap_free(hreg);
while((call1 = delete_calllist_elt(&lazy_affected)) != EMPTY){
subgoal = (VariantSF) call1->goal;
// fprintf(stddbg," considering ");print_subgoal(stdout,subgoal);printf("\n");
if(IsNULL(subgoal)){ /* fact predicates */
call1->deleted = 0;
continue;
}
if (subg_visitors(subgoal)) {
sprint_subgoal(CTXTc forest_log_buffer_1,0,subgoal);
#ifdef ISO_INCR_TABLING
find_the_visitors(CTXTc subgoal);
#else
#ifdef WARN_ON_UNSAFE_UPDATE
xsb_warn("%d Choice point(s) exist to the table for %s -- cannot incrementally update (create_lazy_call_list)\n",
subg_visitors(subgoal),forest_log_buffer_1->fl_buffer);
#else
xsb_abort("%d Choice point(s) exist to the table for %s -- cannot incrementally update (create_lazy_call_list)\n",
subg_visitors(subgoal),forest_log_buffer_1->fl_buffer);
#endif
#endif
continue;
}
// fprintf(stddbg,"adding dependency for ");print_subgoal(stdout,subgoal);printf("\n");
count++;
tif = (TIFptr) subgoal->tif_ptr;
// if (!(psc = TIF_PSC(tif)))
// xsb_table_error(CTXTc "Cannot access dynamic incremental table\n");
psc = TIF_PSC(tif);
arity = get_arity(psc);
check_glstack_overflow(6,pcreg,2+arity*200); // don't know how much for build_subgoal_args...
oldhreg = clref_val(reg[6]); // maybe updated by re-alloc
if(arity>0){
sreg = hreg;
follow(oldhreg++) = makecs(sreg);
hreg += arity + 1; // had 10, why 10? why not 3? 2 for list, 1 for functor (dsw)
new_heap_functor(sreg, psc);
for (j = 1; j <= arity; j++) {
new_heap_free(sreg);
cell_array1[arity-j] = cell(sreg-1);
}
build_subgoal_args(subgoal);
} else {
follow(oldhreg++) = makestring(get_name(psc));
}
reg[6] = follow(oldhreg) = makelist(hreg);
new_heap_free(hreg);
new_heap_free(hreg);
}
if(count > 0) {
follow(oldhreg) = makenil;
hreg -= 2; /* take back the extra words allocated... */
} else
reg[5] = makenil;
return unify(CTXTc reg_term(CTXTc 4),reg_term(CTXTc 5));
/*int i;
for(i=0;i<callqptr;i++){
if(IsNonNULL(callq[i]) && (callq[i]->deleted==1)){
sfPrintGoal(stdout,(VariantSF)callq[i]->goal,NO);
printf(" %d %d\n",callq[i]->falsecount,callq[i]->deleted);
}
}
printf("-----------------------------\n"); */
}
// TLS: factored out this warning because dfs_inedges is recursive and
// this makes the stack frames too big.
void dfs_inedges_warning(CTXTdeclc callnodeptr call1,calllistptr *lazy_affected) {
deallocate_call_list(*lazy_affected);
sprint_subgoal(CTXTc forest_log_buffer_1,0,call1->goal);
xsb_warn("%d Choice point(s) exist to the table for %s -- cannot incrementally update (dfs_inedges)\n",
subg_visitors(call1->goal),forest_log_buffer_1->fl_buffer);
}
/* in order to save builtin numbers, create a single socket function with
* options socket_request(SockOperation,....) */
xsbBool xsb_socket_request(CTXTdecl)
{
int ecode = 0; /* error code for socket ops */
int timeout_flag;
SOCKET sock_handle;
int domain, portnum;
SOCKADDR_IN socket_addr;
struct linger sock_linger_opt;
int rc;
char *message_buffer = NULL; /* initialized to keep compiler happy */
UInteger msg_len = 0; /* initialized to keep compiler happy */
char char_read;
switch (ptoc_int(CTXTc 1)) {
case SOCKET_ROOT: /* this is the socket() request */
/* socket_request(SOCKET_ROOT,+domain,-socket_fd,-Error,_,_,_)
Currently only AF_INET domain */
domain = (int)ptoc_int(CTXTc 2);
if (!translate_domain(domain, &domain)) {
return FALSE;
}
sock_handle = socket(domain, SOCK_STREAM, IPPROTO_TCP);
/* error handling */
if (BAD_SOCKET(sock_handle)) {
ecode = XSB_SOCKET_ERRORCODE;
perror("SOCKET_REQUEST");
} else {
ecode = SOCK_OK;
}
ctop_int(CTXTc 3, (SOCKET) sock_handle);
return set_error_code(CTXTc ecode, 4, "SOCKET_REQUEST");
case SOCKET_BIND:
/* socket_request(SOCKET_BIND,+domain,+sock_handle,+port,-Error,_,_)
Currently only supports AF_INET */
sock_handle = (SOCKET) ptoc_int(CTXTc 3);
portnum = (int)ptoc_int(CTXTc 4);
domain = (int)ptoc_int(CTXTc 2);
if (!translate_domain(domain, &domain)) {
return FALSE;
}
/* Bind server to the agreed upon port number.
** See commdef.h for the actual port number. */
FillWithZeros(socket_addr);
socket_addr.sin_port = htons((unsigned short)portnum);
socket_addr.sin_family = AF_INET;
#ifndef WIN_NT
socket_addr.sin_addr.s_addr = htonl(INADDR_ANY);
#endif
rc = bind(sock_handle, (PSOCKADDR) &socket_addr, sizeof(socket_addr));
/* error handling */
if (SOCKET_OP_FAILED(rc)) {
ecode = XSB_SOCKET_ERRORCODE;
perror("SOCKET_BIND");
} else
ecode = SOCK_OK;
return set_error_code(CTXTc ecode, 5, "SOCKET_BIND");
case SOCKET_LISTEN:
/* socket_request(SOCKET_LISTEN,+sock_handle,+length,-Error,_,_,_) */
sock_handle = (SOCKET) ptoc_int(CTXTc 2);
rc = listen(sock_handle, (int)ptoc_int(CTXTc 3));
/* error handling */
if (SOCKET_OP_FAILED(rc)) {
ecode = XSB_SOCKET_ERRORCODE;
perror("SOCKET_LISTEN");
} else
ecode = SOCK_OK;
return set_error_code(CTXTc ecode, 4, "SOCKET_LISTEN");
case SOCKET_ACCEPT:
timeout_flag = socket_accept(CTXTc (SOCKET *)&rc, (int)pflags[SYS_TIMER]);
if (timeout_flag == TIMED_OUT) {
return set_error_code(CTXTc TIMEOUT_ERR, 4, "SOCKET_SEND");
} else {
/* error handling */
if (BAD_SOCKET(rc)) {
ecode = XSB_SOCKET_ERRORCODE;
perror("SOCKET_ACCEPT");
sock_handle = rc; /* shut up warning */
} else {
sock_handle = rc; /* accept() returns sock_out */
ecode = SOCK_OK;
}
ctop_int(CTXTc 3, (SOCKET) sock_handle);
return set_error_code(CTXTc ecode, 4, "SOCKET_ACCEPT");
}
case SOCKET_CONNECT: {
/* socket_request(SOCKET_CONNECT,+domain,+sock_handle,+port,
+hostname,-Error) */
timeout_flag = socket_connect(CTXTc &rc, (int)pflags[SYS_TIMER]);
if (timeout_flag == TIMED_OUT) {
return set_error_code(CTXTc TIMEOUT_ERR, 6, "SOCKET_CONNECT");
} else if (timeout_flag == TIMER_SETUP_ERR) {
return set_error_code(CTXTc TIMER_SETUP_ERR, 6, "SOCKET_CONNECT");
} else {
/* error handling */
if (SOCKET_OP_FAILED(rc)) {
ecode = XSB_SOCKET_ERRORCODE;
perror("SOCKET_CONNECT");
/* close, because if connect() fails then socket becomes unusable */
closesocket(ptoc_int(CTXTc 3));
} else {
ecode = SOCK_OK;
}
return set_error_code(CTXTc ecode, 6, "SOCKET_CONNECT");
}
}
case SOCKET_CLOSE:
/* socket_request(SOCKET_CLOSE,+sock_handle,-Error,_,_,_,_) */
sock_handle = (SOCKET)ptoc_int(CTXTc 2);
/* error handling */
rc = closesocket(sock_handle);
if (SOCKET_OP_FAILED(rc)) {
ecode = XSB_SOCKET_ERRORCODE;
perror("SOCKET_CLOSE");
} else
ecode = SOCK_OK;
return set_error_code(CTXTc ecode, 3, "SOCKET_CLOSE");
case SOCKET_RECV:
/* socket_request(SOCKET_RECV,+Sockfd, -Msg, -Error,_,_,_) */
// TODO: consider adding protection against interrupts, EINTR, like
// in socket_get0.
timeout_flag = socket_recv(CTXTc &rc, &message_buffer, &msg_len, (int)pflags[SYS_TIMER]);
if (timeout_flag == TIMED_OUT) {
return set_error_code(CTXTc TIMEOUT_ERR, 4, "SOCKET_SEND");
} else {
/* error handling */
switch (rc) {
case SOCK_OK:
ecode = SOCK_OK;
break;
case SOCK_READMSG_FAILED:
ecode = XSB_SOCKET_ERRORCODE;
perror("SOCKET_RECV");
break;
case SOCK_READMSG_EOF:
ecode = SOCK_EOF;
break;
case SOCK_HEADER_LEN_MISMATCH:
ecode = XSB_SOCKET_ERRORCODE;
break;
default:
xsb_abort("XSB bug: [SOCKET_RECV] invalid return code from readmsg");
}
if (message_buffer != NULL) {
/* use message_buffer+XSB_MSG_HEADER_LENGTH because the first
XSB_MSG_HEADER_LENGTH bytes are for the message length header */
ctop_string(CTXTc 3, (char*)message_buffer+XSB_MSG_HEADER_LENGTH);
mem_dealloc(message_buffer,msg_len,OTHER_SPACE);
} else { /* this happens at the end of a file */
ctop_string(CTXTc 3, (char*)"");
}
return set_error_code(CTXTc ecode, 4, "SOCKET_RECV");
}
case SOCKET_SEND:
/* socket_request(SOCKET_SEND,+Sockfd, +Msg, -Error,_,_,_) */
timeout_flag = socket_send(CTXTc &rc, (int)pflags[SYS_TIMER]);
if (timeout_flag == TIMED_OUT) {
return set_error_code(CTXTc TIMEOUT_ERR, 4, "SOCKET_SEND");
} else {
/* error handling */
if (SOCKET_OP_FAILED(rc)) {
ecode = XSB_SOCKET_ERRORCODE;
perror("SOCKET_SEND");
} else {
ecode = SOCK_OK;
}
return set_error_code(CTXTc ecode, 4, "SOCKET_SEND");
}
case SOCKET_GET0:
/* socket_request(SOCKET_GET0,+Sockfd,-C,-Error,_,_,_) */
message_buffer = &char_read;
timeout_flag = socket_get0(CTXTc &rc, message_buffer, (int)pflags[SYS_TIMER]);
if (timeout_flag == TIMED_OUT) {
return set_error_code(CTXTc TIMEOUT_ERR, 4, "SOCKET_SEND");
} else {
/*error handling */
switch (rc) {
case 1:
ctop_int(CTXTc 3,(unsigned char)message_buffer[0]);
ecode = SOCK_OK;
break;
case 0:
ecode = SOCK_EOF;
break;
default:
ctop_int(CTXTc 3,-1);
perror("SOCKET_GET0");
ecode = XSB_SOCKET_ERRORCODE;
}
return set_error_code(CTXTc ecode, 4, "SOCKET_GET0");
}
case SOCKET_PUT:
/* socket_request(SOCKET_PUT,+Sockfd,+C,-Error_,_,_) */
timeout_flag = socket_put(CTXTc &rc, (int)pflags[SYS_TIMER]);
if (timeout_flag == TIMED_OUT) {
return set_error_code(CTXTc TIMEOUT_ERR, 4, "SOCKET_SEND");
} else {
/* error handling */
if (rc == 1) {
ecode = SOCK_OK;
} else if (SOCKET_OP_FAILED(rc)) {
ecode = XSB_SOCKET_ERRORCODE;
perror("SOCKET_PUT");
}
return set_error_code(CTXTc ecode, 4, "SOCKET_PUT");
}
case SOCKET_SET_OPTION: {
/* socket_request(SOCKET_SET_OPTION,+Sockfd,+OptionName,+Value,_,_,_) */
char *option_name = ptoc_string(CTXTc 3);
sock_handle = (SOCKET)ptoc_int(CTXTc 2);
/* Set the "linger" parameter to a small number of seconds */
if (0==strcmp(option_name,"linger")) {
int linger_time=(int)ptoc_int(CTXTc 4);
if (linger_time < 0) {
sock_linger_opt.l_onoff = FALSE;
sock_linger_opt.l_linger = 0;
} else {
sock_linger_opt.l_onoff = TRUE;
sock_linger_opt.l_linger = linger_time;
}
if (SETSOCKOPT(sock_handle, SOL_SOCKET, SO_LINGER,
&sock_linger_opt, sizeof(sock_linger_opt))
< 0) {
xsb_warn(CTXTc "[SOCKET_SET_OPTION] Cannot set socket linger time");
return FALSE;
}
}else {
xsb_warn(CTXTc "[SOCKET_SET_OPTION] Invalid option, `%s'", option_name);
return FALSE;
}
return TRUE;
}
case SOCKET_SET_SELECT: {
/*socket_request(SOCKET_SET_SELECT,+connection_name,
+R_sockfd,+W_sockfd,+E_sockfd) */
prolog_term R_sockfd, W_sockfd, E_sockfd;
int i, connection_count;
int rmax_fd=0, wmax_fd=0, emax_fd=0;
char *connection_name = ptoc_string(CTXTc 2);
/* bind fds to input arguments */
R_sockfd = reg_term(CTXTc 3);
W_sockfd = reg_term(CTXTc 4);
E_sockfd = reg_term(CTXTc 5);
/* initialize the array of connect_t structure for select call */
init_connections(CTXT);
SYS_MUTEX_LOCK(MUTEX_SOCKETS);
/* check whether the same connection name exists */
for (i=0;i<MAXCONNECT;i++) {
if ((connections[i].empty_flag==FALSE) &&
(strcmp(connection_name,connections[i].connection_name)==0))
xsb_abort("[SOCKET_SET_SELECT] Connection `%s' already exists!",
connection_name);
}
/* check whether there is empty slot left for connection */
if ((connection_count=checkslot())<MAXCONNECT) {
if (connections[connection_count].connection_name == NULL) {
connections[connection_count].connection_name = connection_name;
connections[connection_count].empty_flag = FALSE;
/* call the utility function separately to take the fds in */
list_sockfd(R_sockfd, &connections[connection_count].readset,
&rmax_fd, &connections[connection_count].read_fds,
&connections[connection_count].sizer);
list_sockfd(W_sockfd, &connections[connection_count].writeset,
&wmax_fd, &connections[connection_count].write_fds,
&connections[connection_count].sizew);
list_sockfd(E_sockfd, &connections[connection_count].exceptionset,
&emax_fd,&connections[connection_count].exception_fds,
&connections[connection_count].sizee);
connections[connection_count].maximum_fd =
xsb_max(xsb_max(rmax_fd,wmax_fd), emax_fd);
} else
/* if this one is reached, it is probably a bug */
xsb_abort("[SOCKET_SET_SELECT] All connections are busy!");
} else
xsb_abort("[SOCKET_SET_SELECT] Max number of collections exceeded!");
SYS_MUTEX_UNLOCK(MUTEX_SOCKETS);
return TRUE;
}
case SOCKET_SELECT: {
/* socket_request(SOCKET_SELECT,+connection_name, +timeout
-avail_rsockfds,-avail_wsockfds,
-avail_esockfds,-ecode)
Returns 3 prolog_terms for available socket fds */
prolog_term Avail_rsockfds, Avail_wsockfds, Avail_esockfds;
prolog_term Avail_rsockfds_tail, Avail_wsockfds_tail, Avail_esockfds_tail;
int maxfd;
int i; /* index for connection_count */
char *connection_name = ptoc_string(CTXTc 2);
struct timeval *tv;
prolog_term timeout_term;
int timeout =0;
int connectname_found = FALSE;
int count=0;
SYS_MUTEX_LOCK(MUTEX_SOCKETS);
/* specify the time out */
timeout_term = reg_term(CTXTc 3);
if (isointeger(timeout_term)) {
timeout = (int)oint_val(timeout_term);
/* initialize tv */
tv = (struct timeval *)mem_alloc(sizeof(struct timeval),LEAK_SPACE);
tv->tv_sec = timeout;
tv->tv_usec = 0;
} else
tv = NULL; /* no timeouts */
/* initialize the prolog term */
Avail_rsockfds = p2p_new(CTXT);
Avail_wsockfds = p2p_new(CTXT);
Avail_esockfds = p2p_new(CTXT);
/* bind to output arguments */
Avail_rsockfds = reg_term(CTXTc 4);
Avail_wsockfds = reg_term(CTXTc 5);
Avail_esockfds = reg_term(CTXTc 6);
Avail_rsockfds_tail = Avail_rsockfds;
Avail_wsockfds_tail = Avail_wsockfds;
Avail_esockfds_tail = Avail_esockfds;
/*
// This was wrong. Lists are now made inside test_ready()
c2p_list(CTXTc Avail_rsockfds_tail);
c2p_list(CTXTc Avail_wsockfds_tail);
c2p_list(CTXTc Avail_esockfds_tail);
*/
for (i=0; i < MAXCONNECT; i++) {
/* find the matching connection_name to select */
if(connections[i].empty_flag==FALSE) {
if (strcmp(connection_name, connections[i].connection_name) == 0) {
connectname_found = TRUE;
count = i;
break;
}
}
}
if( i >= MAXCONNECT ) /* if no matching connection_name */
xsb_abort("[SOCKET_SELECT] connection `%s' doesn't exist",
connection_name);
/* compute maxfd for select call */
maxfd = connections[count].maximum_fd + 1;
/* FD_SET all sockets */
set_sockfd( CTXTc count );
/* test whether the socket fd is available */
rc = select(maxfd, &connections[count].readset,
&connections[count].writeset,
&connections[count].exceptionset, tv);
/* error handling */
if (rc == 0) /* timed out */
ecode = TIMEOUT_ERR;
else if (SOCKET_OP_FAILED(rc)) {
perror("SOCKET_SELECT");
ecode = XSB_SOCKET_ERRORCODE;
} else { /* no error */
ecode = SOCK_OK;
/* call the utility function to return the available socket fds */
test_ready(CTXTc &Avail_rsockfds_tail, &connections[count].readset,
connections[count].read_fds,connections[count].sizer);
test_ready(CTXTc &Avail_wsockfds_tail, &connections[count].writeset,
connections[count].write_fds,connections[count].sizew);
test_ready(CTXTc &Avail_esockfds_tail,&connections[count].exceptionset,
connections[count].exception_fds,connections[count].sizee);
}
SYS_MUTEX_UNLOCK(MUTEX_SOCKETS);
if (tv) mem_dealloc((struct timeval *)tv,sizeof(struct timeval),LEAK_SPACE);
SQUASH_LINUX_COMPILER_WARN(connectname_found) ;
return set_error_code(CTXTc ecode, 7, "SOCKET_SELECT");
}
case SOCKET_SELECT_DESTROY: {
/*socket_request(SOCKET_SELECT_DESTROY, +connection_name) */
char *connection_name = ptoc_string(CTXTc 2);
select_destroy(CTXTc connection_name);
return TRUE;
}
default:
xsb_warn(CTXTc "[SOCKET_REQUEST] Invalid socket request %d", (int) ptoc_int(CTXTc 1));
return FALSE;
}
/* This trick would report a bug, if a newly added case
doesn't have a return clause */
xsb_bug("SOCKET_REQUEST case %d has no return clause", ptoc_int(CTXTc 1));
}
/* spawn a subprocess PROGNAME and pass it the arguments ARGV[]
ARGV must be a NULL-terminated array of strings.
Also pass it two arrays of strings: PIPE_TO_PROC[2] and PIPE_FROM_PROC[2].
These are going to be the arrays of fds for the communication pipes
This function is protected from being called by more than one
thread at a time by a mutex: the context is passed in for error handling.
*/
static int xsb_spawn (CTXTdeclc char *progname, char *argv[], int callno,
int pipe_to_proc[],
int pipe_from_proc[],int pipe_from_stderr[],
FILE *toprocess_fptr, FILE *fromprocess_fptr,
FILE *fromproc_stderr_fptr)
{
int pid;
int stdin_saved, stdout_saved, stderr_saved;
static char shell_command[MAX_CMD_LEN];
if ( (pipe_to_proc != NULL) && PIPE(pipe_to_proc) < 0 ) {
/* can't open pipe to process */
xsb_warn(CTXTc "[SPAWN_PROCESS] Can't open pipe for subprocess input");
return PIPE_TO_PROC_FAILED;
}
if ( (pipe_from_proc != NULL) && PIPE(pipe_from_proc) < 0 ) {
/* can't open pipe from process */
xsb_warn(CTXTc "[SPAWN_PROCESS] Can't open pipe for subprocess output");
return PIPE_FROM_PROC_FAILED;
}
if ( (pipe_from_stderr != NULL) && PIPE(pipe_from_stderr) < 0 ) {
/* can't open stderr pipe from process */
xsb_warn(CTXTc "[SPAWN_PROCESS] Can't open pipe for subprocess errors");
return PIPE_FROM_PROC_FAILED;
}
/* The following is due to the awkwardness of windoze process creation.
We commit this atrocity in order to be portable between Unix and Windows.
1. Save stdio of the parent process.
2. Redirect main process stdio to the pipes.
3. Spawn subprocess. The subprocess inherits the redirected I/O
4. Restore the original stdio for the parent process.
On the bright side, this trick allowed us to cpature the I/O streams of
the shell commands invoked by system()
*/
/* save I/O */
stdin_saved = dup(fileno(stdin));
stdout_saved = dup(fileno(stdout));
stderr_saved = dup(fileno(stderr));
if ((fileno(stdin) < 0) || (stdin_saved < 0))
xsb_warn(CTXTc "[SPAWN_PROCESS] Bad stdin=%d; stdin closed by mistake?",
fileno(stdin));
if ((fileno(stdout) < 0) || (stdout_saved < 0))
xsb_warn(CTXTc "[SPAWN_PROCESS] Bad stdout=%d; stdout closed by mistake?",
fileno(stdout));
if ((fileno(stderr) < 0) || (stderr_saved < 0))
xsb_warn(CTXTc "[SPAWN_PROCESS] Bad stderr=%d; stderr closed by mistake?",
fileno(stderr));
if (pipe_to_proc != NULL) {
/* close child stdin, bind it to the reading part of pipe_to_proc */
if (dup2(pipe_to_proc[0], fileno(stdin)) < 0) {
xsb_warn(CTXTc "[SPAWN_PROCESS] Can't connect pipe %d to subprocess stdin",
pipe_to_proc[0]);
return PIPE_TO_PROC_FAILED;
}
close(pipe_to_proc[0]); /* close the parent read end of pipe */
}
/* if stdin must be captured in an existing I/O port -- do it */
if (toprocess_fptr != NULL)
if (dup2(fileno(toprocess_fptr), fileno(stdin)) < 0) {
xsb_warn(CTXTc "[SPAWN_PROCESS] Can't connect stream %d to subprocess stdin",
fileno(toprocess_fptr));
return PIPE_TO_PROC_FAILED;
}
if (pipe_from_proc != NULL) {
/* close child stdout, bind it to the write part of pipe_from_proc */
if (dup2(pipe_from_proc[1], fileno(stdout)) < 0) {
xsb_warn(CTXTc "[SPAWN_PROCESS] Can't connect subprocess stdout to pipe %d",
pipe_from_proc[1]);
return PIPE_TO_PROC_FAILED;
}
close(pipe_from_proc[1]); /* close the parent write end of pipe */
}
/* if stdout must be captured in an existing I/O port -- do it */
if (fromprocess_fptr != NULL)
if (dup2(fileno(fromprocess_fptr), fileno(stdout)) < 0) {
xsb_warn(CTXTc "[SPAWN_PROCESS] Can't connect subprocess stdout to stream %d",
fileno(fromprocess_fptr));
return PIPE_TO_PROC_FAILED;
}
if (pipe_from_stderr != NULL) {
/* close child stderr, bind it to the write part of pipe_from_proc */
if (dup2(pipe_from_stderr[1], fileno(stderr)) < 0) {
xsb_warn(CTXTc "[SPAWN_PROCESS] Can't connect subprocess stderr to pipe %d",
pipe_from_stderr[1]);
return PIPE_TO_PROC_FAILED;
}
close(pipe_from_stderr[1]); /* close the parent write end of pipe */
}
/* if stderr must be captured in an existing I/O port -- do it */
if (fromproc_stderr_fptr != NULL)
if (dup2(fileno(fromproc_stderr_fptr), fileno(stderr)) < 0) {
xsb_warn(CTXTc "[SPAWN_PROCESS] Can't connect subprocess stderr to stream %d",
fileno(fromproc_stderr_fptr));
return PIPE_TO_PROC_FAILED;
}
if (callno == SPAWN_PROCESS) {
#ifdef WIN_NT
static char bufQuoted[MAX_CMD_LEN + 2*(MAX_SUBPROC_PARAMS + 2)];
const char * argvQuoted[MAX_SUBPROC_PARAMS + 2];
char * argq = bufQuoted;
char * arge = bufQuoted + sizeof(bufQuoted);
char ** argp = argv;
size_t len = 0;
int i;
for (i = 0; i < MAX_SUBPROC_PARAMS + 2; ++i) {
if (*argp && (argq + (len = strlen(*argp)) + 4 < arge)) {
argvQuoted[i] = argq;
*argq++ = '"';
strncpy(argq, *argp, len);
argq += len;
*argq++ = '"';
*argq++ = '\0';
++argp;
} else {
*argq = '\0';
argvQuoted[i] = 0;
break;
}
}
// MK: make the children ignore SIGINT
SetConsoleCtrlHandler(NULL, TRUE);
pid = (int)_spawnvp(P_NOWAIT, progname, argvQuoted);//should pid be Integer?
// MK: restore the normal processing of SIGINT in the parent
SetConsoleCtrlHandler(NULL, FALSE);
#else
pid = fork();
#endif
if (pid < 0) {
/* failed */
xsb_warn(CTXTc "[SPAWN_PROCESS] Can't fork off subprocess");
return pid;
} else if (pid == 0) {
/* child process */
/* Close the writing side of child's in-pipe. Must do this or else the
child won't see EOF when parent closes its end of this pipe. */
if (pipe_to_proc != NULL) close(pipe_to_proc[1]);
/* Close the reading part of child's out-pipe and stderr-pipe */
if (pipe_from_proc != NULL) close(pipe_from_proc[0]);
if (pipe_from_stderr != NULL) close(pipe_from_stderr[0]);
#ifdef WIN_NT
// MK: Not used. Leaving as an example for possible future use
// The below call isn't used. We execute SetConsoleCtrlHandler(NULL,TRUE)
// in the parent, which passes the handling (Ctrl-C ignore) to children.
// Executing SetConsoleCtrlHandler in the child DOES NOT do much.
// SetConsoleCtrlHandler((PHANDLER_ROUTINE) ctrl_C_handler, TRUE);
#else /* Unix: must exec */
// don't let keyboard interrupts kill subprocesses
signal(SIGINT, SIG_IGN);
execvp(progname, argv);
/* if we ever get here, this means that invocation of the process has
failed */
exit(SUB_PROC_FAILED);
#endif
}
} else { /* SHELL command */
/* no separator */
concat_array(CTXTc argv, "", shell_command, MAX_CMD_LEN);
pid = system(shell_command);
}
/* main process continues */
/* duplicate saved copies of stdio fds back into main process stdio */
if (dup2(stdin_saved, fileno(stdin)) < 0) {
perror("SPAWN_PROCESS");
close(stdin_saved); close(stdout_saved); close(stderr_saved);
return PIPE_TO_PROC_FAILED;
}
if (dup2(stdout_saved, fileno(stdout)) < 0) {
perror("SPAWN_PROCESS");
close(stdin_saved); close(stdout_saved); close(stderr_saved);
return PIPE_TO_PROC_FAILED;
}
if (dup2(stderr_saved, fileno(stderr)) < 0) {
perror("SPAWN_PROCESS");
close(stdin_saved); close(stdout_saved); close(stderr_saved);
return PIPE_TO_PROC_FAILED;
}
close(stdin_saved); close(stdout_saved); close(stderr_saved);
return pid;
}
/* 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;
}
