/*-----------------------------------------------------------------------------*/
void ODBCColumns()
{
struct Cursor *cur = (struct Cursor *)ptoc_int(2);
char tmpstr[255];
char *str1, *str2, *str3;
RETCODE rc;
strcpy(tmpstr,ptoc_string(3));
str1 = strtok(tmpstr,".");
str2 = str3 = NULL;
if (str1) str2 = strtok(NULL,".");
if (str2) str3 = strtok(NULL,".");
if (!str3 && !str2) {str3 = str1; str1 = NULL;}
else if (!str3) {str3 = str2; str2 = NULL;}
/* printf("str1 %s, str2 %s, str3 %s\n",str1,str2,str3);*/
if (((rc=SQLColumns(cur->hstmt,
str1, SQL_NTS,
str2, SQL_NTS,
str3, SQL_NTS,
NULL,0)) == SQL_SUCCESS) ||
(rc == SQL_SUCCESS_WITH_INFO)) {
ctop_int(4,0);
} else {
ctop_int(4,PrintErrorMsg(cur));
SetCursorClose(cur);
}
return;
}
/*-----------------------------------------------------------------------------*/
void ODBCTables()
{
struct Cursor *cur = (struct Cursor *)ptoc_int(2);
RETCODE rc;
if (cur->Status == 2) { /* reusing opened cursor*/
rc = SQLFreeStmt(cur->hstmt,SQL_CLOSE);
if ((rc != SQL_SUCCESS) && (rc != SQL_SUCCESS_WITH_INFO)) {
ctop_int(3, PrintErrorMsg(cur));
SetCursorClose(cur);
return;
}
}
if (((rc=SQLTables(cur->hstmt,
NULL, 0,
NULL, 0,
NULL, 0,
NULL, 0)) == SQL_SUCCESS) ||
(rc == SQL_SUCCESS_WITH_INFO)) {
ctop_int(3,0);
} else {
ctop_int(3,PrintErrorMsg(cur));
SetCursorClose(cur);
}
return;
}
/*-----------------------------------------------------------------------------*/
void ODBCUserTables()
{
struct Cursor *cur = (struct Cursor *)ptoc_int(2);
UWORD TablePrivilegeExists;
RETCODE rc;
/* since some ODBC drivers don't implement the function SQLTablePrivileges*/
/* we check it first*/
SQLGetFunctions(cur->hdbc,SQL_API_SQLTABLEPRIVILEGES,&TablePrivilegeExists);
if (!TablePrivilegeExists) {
printf("Privilege concept does not exist in this DVMS: you probably can access any of the existing tables\n");
ctop_int(3, 2);
return;
}
if (((rc=SQLTablePrivileges(cur->hstmt,
NULL, 0,
NULL, 0,
NULL, 0)) == SQL_SUCCESS) ||
(rc == SQL_SUCCESS_WITH_INFO))
ctop_int(3,0);
else {
ctop_int(3,PrintErrorMsg(cur));
SetCursorClose(cur);
}
return;
}
/*-----------------------------------------------------------------------------*/
void Parse()
{
int j;
struct Cursor *cur = (struct Cursor *)ptoc_int(2);
RETCODE rc;
if (cur->Status == 2) { /* reusing opened cursor*/
rc = SQLFreeStmt(cur->hstmt,SQL_CLOSE);
if ((rc != SQL_SUCCESS) && (rc != SQL_SUCCESS_WITH_INFO)) {
ctop_int(3, PrintErrorMsg(cur));
SetCursorClose(cur);
return;
}
/* reset just char select vars, since they store addr of chars*/
for (j = 0; j < cur->NumBindVars; j++) {
if (cur->BindTypes[j] == 2)
rc = SQLBindParameter(cur->hstmt, (short)(j+1), SQL_PARAM_INPUT, SQL_C_CHAR,
SQL_CHAR, 0, 0,(char *) cur->BindList[j], 0, &SQL_NTSval);
}
} else {
if (SQLPrepare(cur->hstmt, cur->Sql, SQL_NTS) != SQL_SUCCESS) {
ctop_int(3,PrintErrorMsg(cur));
SetCursorClose(cur);
return;
}
/* set the bind variables*/
for (j = 0; j < cur->NumBindVars; j++) {
if (cur->BindTypes[j] == 2)
/* we're sloppy here. it's ok for us to use the default values*/
rc = SQLBindParameter(cur->hstmt, (short)(j+1), SQL_PARAM_INPUT, SQL_C_CHAR,
SQL_CHAR, 0, 0,(char *)cur->BindList[j], 0, &SQL_NTSval);
else if (cur->BindTypes[j] == 1) {
rc = SQLBindParameter(cur->hstmt, (short)(j+1), SQL_PARAM_INPUT, SQL_C_FLOAT, SQL_FLOAT,
0, 0, (float *)cur->BindList[j], 0, NULL);
} else
rc = SQLBindParameter(cur->hstmt, (short)(j+1), SQL_PARAM_INPUT, SQL_C_SLONG, SQL_INTEGER,
0, 0, (int *)(cur->BindList[j]), 0, NULL);
if (rc != SQL_SUCCESS) {
ctop_int(3,PrintErrorMsg(cur));
SetCursorClose(cur);
return;
}
}
}
/* submit it for execution*/
if (SQLExecute(cur->hstmt) != SQL_SUCCESS) {
ctop_int(3,PrintErrorMsg(cur));
SetCursorClose(cur);
return;
}
ctop_int(3,0);
return;
}
/* 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;
}
int prand(void)
{
unsigned int r = rand();
r = r & 0xFFFFFF;
ctop_int(1,r);
return(1);
}
/*-----------------------------------------------------------------------------*/
void ODBCConnectOption()
{
HDBC hdbc = (HDBC)ptoc_int(2);
int set = ptoc_int(3);
long value = 0;
RETCODE rc;
if (set) {
rc = SQLSetConnectOption(hdbc,(UWORD)ptoc_int(4),(UDWORD)ptoc_int(5));
} else {
rc = SQLGetConnectOption(hdbc,(UWORD)ptoc_int(4),(PTR)&value);
ctop_int(5,value);
}
if ((rc == SQL_SUCCESS) || (rc == SQL_SUCCESS_WITH_INFO))
ctop_int(6,0);
else ctop_int(6,PrintErrorMsg(NULL));
}
/*-----------------------------------------------------------------------------*/
void ODBCRollback()
{
struct Cursor *cur = FCursor;
HDBC hdbc = (HDBC)ptoc_int(2);
RETCODE rc;
if (((rc=SQLTransact(henv,hdbc,SQL_ROLLBACK)) == SQL_SUCCESS) ||
(rc == SQL_SUCCESS_WITH_INFO)) {
/* only close those with right hdbc*/
while (cur != NULL) {
if (cur->hdbc == hdbc && cur->Status != 0) SetCursorClose(cur);
cur = cur->NCursor;
}
ctop_int(3,0);
} else
ctop_int(3, PrintErrorMsg(NULL));
return;
}
/* 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;
}
/*----------------------------------------------------------------------------
do_bulk_match__()
The pattern match function which includes loading perl interpreter and
doing the global perl pattern match, and storing the results in the global
array of bulkMatchList.
argument:
input: char* string -- input text
char* pattern -- match pattern
output: int* num_match -- the number of the matches
----------------------------------------------------------------------------*/
int do_bulk_match__( void )
{
AV *match_list; /* AV storage of matches list*/
SV *text; /* storage for the embedded perl cmd */
SV *string_buff; /* storage for the embedded perl cmd */
int num_match; /* the number of the matches */
int i;
#ifdef MULTI_THREAD
if( NULL == th)
th = xsb_get_main_thread();
#endif
/* first load the perl interpreter, if unloaded */
if (perlObjectStatus == UNLOADED) load_perl__();
text = newSV(0);
string_buff = newSV(0);
sv_setpv(text, ptoc_string(CTXTc 1)); /*put the string into an SV */
/*------------------------------------------------------------------------
free the old match list space and allocate new space for current match list
-----------------------------------------------------------------------*/
for ( i=0; i<preBulkMatchNumber; i++ )
free(bulkMatchList[i]);
if (bulkMatchList != NULL ) free(bulkMatchList);
bulkMatchList = NULL;
/*------------------------------------------------------------------------
do bulk match
----------------------------------------------------------------------*/
num_match = all_matches(text, ptoc_string(CTXTc 2),&match_list);
/* allocate the space to store the matches */
if ( num_match != 0 ) {
preBulkMatchNumber = num_match; /* reset the pre bulk match number */
bulkMatchList = (char **)malloc(num_match*sizeof(char *));
if ( bulkMatchList == NULL )
xsb_abort("Cannot alocate memory to store the results for bulk match");
}
/*get the matches from the AV */
for ( i=0;i<num_match;i++ ) {
string_buff = av_shift(match_list);
bulkMatchList[i] = (char *)malloc( strlen(SvPV(string_buff,PL_na))+1 );
strcpy((char *)bulkMatchList[i], SvPV(string_buff,PL_na) );
}
SvREFCNT_dec(string_buff); /* release space*/
SvREFCNT_dec(text);
ctop_int(CTXTc 3, num_match); /*return the number of matches*/
return SUCCESS;
}
/*-----------------------------------------------------------------------------*/
void FetchNextRow()
{
struct Cursor *cur = (struct Cursor *)ptoc_int(2);
RETCODE rc;
if (!serverConnected || cur->Status == 0) {
ctop_int(3,2);
return;
}
rc = SQLFetch(cur->hstmt);
if ((rc == SQL_SUCCESS) || (rc == SQL_SUCCESS_WITH_INFO))
ctop_int(3,0);
else if (rc == SQL_NO_DATA_FOUND){
cur->Status = 1; /* done w/fetching. set cursor status to unused */
ctop_int(3,1);
}
else {
SetCursorClose(cur); /* error occured in fetching*/
ctop_int(3,2);
}
return;
}
/*-----------------------------------------------------------------------------*/
void ODBCDescribeSelect()
{
int j;
UCHAR colname[50];
SWORD colnamelen;
SWORD scale;
SWORD nullable;
UDWORD collen;
struct Cursor *cur = (struct Cursor *)ptoc_int(2);
cur->NumCols = 0;
SQLNumResultCols(cur->hstmt, (SQLSMALLINT*)&(cur->NumCols));
if (!(cur->NumCols)) {
/* no columns are affected, set cursor status to unused */
cur->Status = 1;
ctop_int(3,2);
return;
}
/* if we aren't reusing a closed statement handle, we need to get*/
/* resulting rowset info and allocate memory for it*/
if (cur->Status != 2) {
cur->ColTypes =
(SWORD *)malloc(sizeof(SWORD) * cur->NumCols);
if (!cur->ColTypes)
xsb_exit("Not enough memory for ColTypes!");
cur->Data =
(UCHAR **)malloc(sizeof(char *) * cur->NumCols);
if (!cur->Data)
xsb_exit("Not enough memory for Data!");
cur->OutLen =
(UDWORD *)malloc(sizeof(UDWORD) * cur->NumCols);
if (!cur->OutLen)
xsb_exit("Not enough memory for OutLen!");
cur->ColLen =
(UDWORD *)malloc(sizeof(UDWORD) * cur->NumCols);
if (!cur->ColLen)
xsb_exit("Not enough memory for ColLen!");
for (j = 0; j < cur->NumCols; j++) {
SQLDescribeCol(cur->hstmt, (short)(j+1), (UCHAR FAR*)colname,
sizeof(colname), &colnamelen,
&(cur->ColTypes[j]),
&collen, &scale, &nullable);
/* SQLServer returns this wierd type for a system table, treat it as varchar?*/
if (cur->ColTypes[j] == -9) cur->ColTypes[j] = SQL_VARCHAR;
colnamelen = (colnamelen > 49) ? 49 : colnamelen;
colname[colnamelen] = '\0';
if (!(cur->ColLen[j] =
DisplayColSize(cur->ColTypes[j],collen,colname))) {
/* let SetCursorClose function correctly free all the memory allocated*/
/* for Data storage: cur->Data[j]'s*/
cur->NumCols = j; /* set so close frees memory allocated thus far*/
SetCursorClose(cur);
/* return(1);*/
ctop_int(3,1);
return;
}
cur->Data[j] =
(UCHAR *) malloc(((unsigned) cur->ColLen[j]+1)*sizeof(UCHAR));
if (!cur->Data[j])
xsb_exit("Not enough memory for Data[j]!");
}
}
/* bind them*/
for (j = 0; j < cur->NumCols; j++) {
SQLBindCol(cur->hstmt, (short)(j+1),
ODBCToXSBType(cur->ColTypes[j]), cur->Data[j],
cur->ColLen[j], (SDWORD FAR *)(&(cur->OutLen[j])));
}
/* return 0;*/
ctop_int(3,0);
return;
}
/* 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 sys_syscall(CTXTdeclc int callno)
{
int result=-1;
struct stat stat_buff;
switch (callno) {
case SYS_exit: {
int exit_code;
exit_code = (int)ptoc_int(CTXTc 3);
xsb_error("\nXSB exited with exit code: %d", exit_code);
exit(exit_code); break;
}
case SYS_getpid :
#ifndef WIN_NT
result = getpid();
#else
result = _getpid();
#endif
break;
#if (!defined(WIN_NT))
case SYS_link :
result = link(ptoc_longstring(CTXTc 3), ptoc_longstring(CTXTc 4));
break;
#endif
case SYS_mkdir: {
#ifndef WIN_NT
/* create using mode 700 */
result = mkdir(ptoc_longstring(CTXTc 3), 0700);
#else
result = _mkdir(ptoc_longstring(CTXTc 3));
#endif
break;
}
case SYS_rmdir: {
#ifndef WIN_NT
result = rmdir(ptoc_longstring(CTXTc 3));
#else
result = _rmdir(ptoc_longstring(CTXTc 3));
#endif
break;
}
case SYS_unlink: result = unlink(ptoc_longstring(CTXTc 3)); break;
case SYS_chdir : result = chdir(ptoc_longstring(CTXTc 3)); break;
case SYS_access: {
switch(*ptoc_string(CTXTc 4)) {
case 'r': /* read permission */
result = access(ptoc_longstring(CTXTc 3), R_OK_XSB);
break;
case 'w': /* write permission */
result = access(ptoc_longstring(CTXTc 3), W_OK_XSB);
break;
case 'x': /* execute permission */
result = access(ptoc_longstring(CTXTc 3), X_OK_XSB);
break;
default:
result = -1;
}
break;
}
case SYS_stat : {
/* Who put this in??? What did s/he expect to get out of this call?
stat_buff is never returned (and what do you do with it in Prolog?)!!!
*/
result = stat(ptoc_longstring(CTXTc 3), &stat_buff);
break;
}
case SYS_rename:
result = rename(ptoc_longstring(CTXTc 3), ptoc_longstring(CTXTc 4));
break;
case SYS_cwd: {
char current_dir[MAX_CMD_LEN];
/* returns 0, if != NULL, 1 otherwise */
result = (getcwd(current_dir, MAX_CMD_LEN-1) == NULL);
if (result == 0)
ctop_string(CTXTc 3,current_dir);
break;
}
case SYS_filecopy: {
char *from = ptoc_longstring(CTXTc 3);
char *to = ptoc_longstring(CTXTc 4);
result = (file_copy(CTXTc from,to,"w") == 0);
break;
}
case SYS_fileappend: {
char *from = ptoc_longstring(CTXTc 3);
char *to = ptoc_longstring(CTXTc 4);
result = (file_copy(CTXTc from,to,"a") == 0);
break;
}
case SYS_create: {
result = open(ptoc_longstring(CTXTc 3),O_CREAT|O_EXCL,S_IREAD|S_IWRITE);
if (result >= 0) close(result);
break;
}
case SYS_readlink: {
char *inpath = ptoc_longstring(CTXTc 3);
// char *outpath = file_readlink(CTXTc inpath);
char *outpath = file_readlink(inpath);
if (outpath == NULL) {
// memory for this case is dealocated in file_readlink in pathname_xsb.c
result = -1;
} else {
ctop_string(CTXTc 4,outpath);
mem_dealloc(outpath,MAXPATHLEN,OTHER_SPACE);
result = 0;
}
break;
}
case SYS_realpath: {
char *inpath = ptoc_longstring(CTXTc 3);
char *outpath = file_realpath(inpath);
if (outpath == NULL) {
// memory for this case is dealocated in file_readlink in pathname_xsb.c
result = -1;
} else {
ctop_string(CTXTc 4,outpath);
mem_dealloc(outpath,MAXPATHLEN,OTHER_SPACE);
result = 0;
}
break;
}
case STATISTICS_2: {
get_statistics(CTXT);
break;
}
case SYS_epoch_seconds: {
ctop_int(CTXTc 3,(Integer)time(0));
break;
}
case SYS_epoch_msecs: {
static struct timeb time_epoch;
ftime(&time_epoch);
ctop_int(CTXTc 3,(Integer)(time_epoch.time));
ctop_int(CTXTc 4,(Integer)(time_epoch.millitm));
break;
}
case SYS_main_memory_size: {
size_t memory_size = getMemorySize();
ctop_int(CTXTc 3,(UInteger)memory_size);
break;
}
default: xsb_abort("[SYS_SYSCALL] Unknown system call number, %d", callno);
}
return result;
}
/*-----------------------------------------------------------------------------*/
int GetColumn()
{
struct Cursor *cur = (struct Cursor *)ptoc_int(2);
int ColCurNum = ptoc_int(3);
Cell op1;
Cell op = ptoc_tag(4);
UDWORD len;
if (ColCurNum < 0 || ColCurNum >= cur->NumCols) {
/* no more columns in the result row*/
ctop_int(5,1);
return TRUE;
}
ctop_int(5,0);
/* get the data*/
if (cur->OutLen[ColCurNum] == SQL_NULL_DATA) {
/* column value is NULL*/
return unify(op,nullStrAtom);
}
/* convert the string to either integer, float or string*/
/* according to the column type and pass it back to XSB*/
switch (ODBCToXSBType(cur->ColTypes[ColCurNum])) {
case SQL_C_CHAR:
/* convert the column string to a C string */
len = ((cur->ColLen[ColCurNum] < cur->OutLen[ColCurNum])?
cur->ColLen[ColCurNum]:cur->OutLen[ColCurNum]);
*(cur->Data[ColCurNum]+len) = '\0';
/* compare strings here, so don't intern strings unnecessarily*/
XSB_Deref(op);
if (isref(op))
return unify(op, makestring(string_find(cur->Data[ColCurNum],1)));
if (isconstr(op) && get_arity(get_str_psc(op)) == 1) {
STRFILE strfile;
op1 = cell(clref_val(op)+1);
XSB_Deref(op1);
strfile.strcnt = strlen(cur->Data[ColCurNum]);
strfile.strptr = strfile.strbase = cur->Data[ColCurNum];
read_canonical_term(NULL,&strfile,op1); /* terminating '.'? */
return TRUE;
}
if (!isstring(op)) return FALSE;
if (strcmp(string_val(op),cur->Data[ColCurNum])) return FALSE;
return TRUE;
case SQL_C_BINARY:
/* convert the column string to a C string */
len = ((cur->ColLen[ColCurNum] < cur->OutLen[ColCurNum])?
cur->ColLen[ColCurNum]:cur->OutLen[ColCurNum]);
*(cur->Data[ColCurNum]+len) = '\0';
/* compare strings here, so don't intern strings unnecessarily*/
XSB_Deref(op);
if (isref(op))
return unify(op, makestring(string_find(cur->Data[ColCurNum],1)));
if (isconstr(op) && get_arity(get_str_psc(op)) == 1) {
STRFILE strfile;
op1 = cell(clref_val(op)+1);
XSB_Deref(op1);
strfile.strcnt = strlen(cur->Data[ColCurNum]);
strfile.strptr = strfile.strbase = cur->Data[ColCurNum];
read_canonical_term(NULL,&strfile,op1); /* terminating '.'? */
return TRUE;
}
if (!isstring(op)) return FALSE;
if (strcmp(string_val(op),cur->Data[ColCurNum])) return FALSE;
return TRUE;
case SQL_C_SLONG:
return unify(op,makeint(*(long *)(cur->Data[ColCurNum])));
case SQL_C_FLOAT:
return unify(op,makefloat(*(float *)(cur->Data[ColCurNum])));
}
return FALSE;
}
/*-----------------------------------------------------------------------------*/
void ODBCConnect()
{
UCHAR *server;
UCHAR *pwd;
UCHAR *connectIn;
HDBC hdbc = NULL;
RETCODE rc;
/* if we don't yet have an environment, allocate one.*/
if (!henv) {
/* allocate environment handler*/
rc = SQLAllocEnv(&henv);
if (rc != SQL_SUCCESS && rc != SQL_SUCCESS_WITH_INFO) {
xsb_error("Environment allocation failed");
ctop_int(6, 0);
return;
}
/* SQLSetEnvAttr(henv, SQL_ATTR_ODBC_VERSION, (SQLPOINTER)SQL_OV_ODBC2,
SQL_IS_UINTEGER);
*/
LCursor = FCursor = NULL;
FCurNum = NULL;
nullStrAtom = makestring(string_find("NULL",1));
}
/* allocate connection handler*/
rc = SQLAllocConnect(henv, &hdbc);
if (rc != SQL_SUCCESS && rc != SQL_SUCCESS_WITH_INFO) {
xsb_error("Connection Resources Allocation Failed");
ctop_int(6, 0);
return;
}
if (!ptoc_int(2)) {
/* get server name, user id and password*/
server = (UCHAR *)ptoc_string(3);
strcpy(uid, (UCHAR *)ptoc_string(4));
pwd = (UCHAR *)ptoc_string(5);
/* connect to database*/
rc = SQLConnect(hdbc, server, SQL_NTS, uid, SQL_NTS, pwd, SQL_NTS);
if (rc != SQL_SUCCESS && rc != SQL_SUCCESS_WITH_INFO) {
SQLFreeConnect(hdbc);
xsb_error("Connection to server %s failed", server);
ctop_int(6, 0);
return;
}
} else {
/* connecting through driver using a connection string */
connectIn = (UCHAR *)ptoc_longstring(3);
rc = SQLDriverConnect(hdbc, NULL, connectIn, SQL_NTS, NULL, 0, NULL,SQL_DRIVER_NOPROMPT);
if (rc != SQL_SUCCESS && rc != SQL_SUCCESS_WITH_INFO) {
SQLFreeConnect(hdbc);
xsb_error("Connection to driver failed: %s", connectIn);
ctop_int(6, 0);
return;
}
}
serverConnected = 1;
ctop_int(6, (long)hdbc);
return;
}
/* 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));
}
/*-----------------------------------------------------------------------------*/
void FindFreeCursor()
{
struct Cursor *curi = FCursor, *curj = NULL, *curk = NULL;
struct NumberofCursors *num = FCurNum;
HDBC hdbc = (HDBC)ptoc_int(2);
char *Sql_stmt = ptoc_longstring(3);
RETCODE rc;
/* search */
while (curi != NULL) {
if (curi->hdbc == hdbc) { /* only look at stmt handles for this connection */
if (curi->Status == 0) curj = curi; /* cursor never been used*/
else {
if (curi->Status == 1) { /* a closed cursor*/
/* same statement as this one, so grab and return it*/
if (!strcmp(curi->Sql,Sql_stmt)) {
if (curi != FCursor) {
(curi->PCursor)->NCursor = curi->NCursor;
if (curi == LCursor) LCursor = curi->PCursor;
else (curi->NCursor)->PCursor = curi->PCursor;
FCursor->PCursor = curi;
curi->PCursor = NULL;
curi->NCursor = FCursor;
FCursor = curi;
}
curi->Status = 2;
ctop_int(4, (long)curi);
/*printf("reuse cursor: %p\n",curi);*/
return;
} else {
curk = curi; /* otherwise just record it*/
}
}
}
}
curi = curi->NCursor;
}
/* done w/ the search; see what was found*/
if (curj != NULL) { /* give priority to an unused cursor*/
curi = curj;
/*printf("take unused cursor: %p\n",curi);*/
}
else {
while((num != NULL) && (num->hdbc != hdbc)){
num=num->NCurNum;
}
if(num == NULL){
num = (struct NumberofCursors *)malloc(sizeof(struct NumberofCursors));
num->hdbc = hdbc;
num->NCurNum=FCurNum;
FCurNum=num;
num->CursorCount=0;
}
if (num->CursorCount < MAXCURSORNUM) { /* allocate a new cursor if allowed*/
/* problem here: should have numberOfCursors for each connection */
curi = (struct Cursor *)calloc(sizeof(struct Cursor),1);
curi->PCursor = NULL;
curi->NCursor = FCursor;
if (FCursor == NULL) LCursor = curi;
else FCursor->PCursor = curi;
FCursor = curi;
rc = SQLAllocStmt(hdbc,&(curi->hstmt));
if (!((rc==SQL_SUCCESS) ||
(rc==SQL_SUCCESS_WITH_INFO))) {
free(curi);
/* numberOfCursors--; */
xsb_abort("while trying to allocate ODBC statement\n");
}
num->CursorCount++;
/*printf("allocate a new cursor: %p\n",curi);*/
}
else if (curk == NULL) { /* no cursor left*/
ctop_int(4, 0);
return;
}
else { /* steal a cursor*/
curi = curk;
SetCursorClose(curi);
/*printf("steal a cursor: %p\n",curi);*/
}
}
/* move to front of list.*/
if (curi != FCursor) {
(curi->PCursor)->NCursor = curi->NCursor;
if (curi == LCursor) LCursor = curi->PCursor;
else (curi->NCursor)->PCursor = curi->PCursor;
FCursor->PCursor = curi;
curi->PCursor = NULL;
curi->NCursor = FCursor;
FCursor = curi;
}
curi->hdbc = hdbc;
curi->Sql = (UCHAR *)strdup(Sql_stmt);
if (!curi->Sql)
xsb_exit("Not enough memory for SQL stmt in FindFreeCursor!");
curi->Status = 3;
ctop_int(4, (long)curi);
return;
}
void get_memory_statistics_1(CTXTdeclc double elapstime, int type) {
COMMON_MEMSTAT_DECLS;
NodeStats
pri_tbtn, /* Table Basic Trie Nodes */
pri_tstn, /* Time Stamp Trie Nodes */
pri_aln, /* Answer List Nodes */
pri_asi, /* Answer Subst Info for conditional answers */
pri_tsi, /* Time Stamp Indices (Index Entries/Nodes) */
pri_varsf, /* Variant Subgoal Frames */
pri_prodsf, /* Subsumptive Producer Subgoal Frames */
pri_conssf; /* Subsumptive Consumer Subgoal Frames */
HashStats
tbtht, /* Table Basic Trie Hash Tables */
abtht, /* Asserted Basic Trie Hash Tables */
pri_tbtht, /* Table Basic Trie Hash Tables */
pri_tstht; /* Time Stamp Trie Hash Tables */
size_t
total_alloc, total_used,
tablespace_sm_alloc, tablespace_sm_used,
private_tablespace_sm_alloc, private_tablespace_sm_used,
shared_tablespace_sm_alloc, shared_tablespace_sm_used,
trieassert_alloc, trieassert_used,
gl_avail, tc_avail,
de_space_alloc, de_space_used,
dl_space_alloc, dl_space_used,
pnde_space_alloc, pnde_space_used,
private_de_space_alloc, private_de_space_used,
private_dl_space_alloc, private_dl_space_used,
private_pnde_space_alloc, private_pnde_space_used,
pspacetot;
size_t
num_de_blocks, num_dl_blocks, num_pnde_blocks,
de_count, dl_count, private_de_count, private_dl_count,
i;
tbtn = node_statistics(&smTableBTN);
tbtht = hash_statistics(CTXTc &smTableBTHT);
varsf = subgoal_statistics(CTXTc &smVarSF);
aln = node_statistics(&smALN);
asi = node_statistics(&smASI);
pri_tbtn = node_statistics(&smTableBTN);
pri_tbtht = hash_statistics(CTXTc &smTableBTHT);
pri_varsf = subgoal_statistics(CTXTc &smVarSF);
pri_aln = node_statistics(&smALN);
pri_asi = node_statistics(&smASI);
pri_prodsf = subgoal_statistics(CTXTc &smProdSF);
pri_conssf = subgoal_statistics(CTXTc &smConsSF);
pri_tstn = node_statistics(&smTSTN);
pri_tstht = hash_statistics(CTXTc &smTSTHT);
pri_tsi = node_statistics(&smTSIN);
private_tablespace_sm_alloc = CurrentPrivateTableSpaceAlloc(pri_tbtn,pri_tbtht,pri_varsf,
pri_prodsf,
pri_conssf,pri_aln,pri_tstn,pri_tstht,pri_tsi,pri_asi);
private_tablespace_sm_used = CurrentPrivateTableSpaceUsed(pri_tbtn,pri_tbtht,pri_varsf,
pri_prodsf,
pri_conssf,pri_aln,pri_tstn,pri_tstht,pri_tsi,pri_asi);
shared_tablespace_sm_alloc = CurrentSharedTableSpaceAlloc(tbtn,tbtht,varsf,aln,asi);
shared_tablespace_sm_used = CurrentSharedTableSpaceUsed(tbtn,tbtht,varsf,aln,asi);
tablespace_sm_alloc = shared_tablespace_sm_alloc + private_tablespace_sm_alloc;
tablespace_sm_used = shared_tablespace_sm_used + private_tablespace_sm_used;
de_space_alloc = allocated_de_space(current_de_block_gl,&num_de_blocks);
de_space_used = de_space_alloc - unused_de_space();
de_count = (de_space_used - num_de_blocks * sizeof(Cell)) / sizeof(struct delay_element);
dl_space_alloc = allocated_dl_space(current_dl_block_gl,&num_dl_blocks);
dl_space_used = dl_space_alloc - unused_dl_space();
dl_count = (dl_space_used - num_dl_blocks * sizeof(Cell)) / sizeof(struct delay_list);
pnde_space_alloc = allocated_pnde_space(current_pnde_block_gl,&num_pnde_blocks);
pnde_space_used = pnde_space_alloc - unused_pnde_space();
private_de_space_alloc = allocated_de_space(private_current_de_block,&num_de_blocks);
private_de_space_used = private_de_space_alloc - unused_de_space_private(CTXT);
private_de_count = (private_de_space_used - num_de_blocks * sizeof(Cell)) /
sizeof(struct delay_element);
private_dl_space_alloc = allocated_dl_space(private_current_dl_block,&num_dl_blocks);
private_dl_space_used = private_dl_space_alloc - unused_dl_space_private(CTXT);
private_dl_count = (private_dl_space_used - num_dl_blocks * sizeof(Cell)) /
sizeof(struct delay_list);
private_pnde_space_alloc = allocated_pnde_space(private_current_pnde_block,&num_pnde_blocks);
private_pnde_space_used = private_pnde_space_alloc - unused_pnde_space_private(CTXT);
tablespace_sm_alloc = tablespace_sm_alloc + de_space_alloc + dl_space_alloc + pnde_space_alloc;
tablespace_sm_used = tablespace_sm_used + de_space_used + dl_space_used + pnde_space_alloc;
shared_tablespace_sm_alloc = shared_tablespace_sm_alloc + de_space_alloc + dl_space_alloc
+ pnde_space_alloc;
shared_tablespace_sm_used = shared_tablespace_sm_used + de_space_used + dl_space_used
+ pnde_space_used;
private_tablespace_sm_alloc = private_tablespace_sm_alloc + private_de_space_alloc +
private_dl_space_alloc + private_pnde_space_alloc;
private_tablespace_sm_used = private_tablespace_sm_used + private_de_space_used +
private_dl_space_used + private_pnde_space_used;
abtn = node_statistics(&smAssertBTN);
abtht = hash_statistics(CTXTc &smAssertBTHT);
trieassert_alloc =
NodeStats_SizeAllocNodes(abtn) + HashStats_SizeAllocTotal(abtht);
trieassert_used =
NodeStats_SizeUsedNodes(abtn) + HashStats_SizeUsedTotal(abtht);
gl_avail = (top_of_localstk - top_of_heap - 1) * sizeof(Cell);
tc_avail = (top_of_cpstack - (CPtr)top_of_trail - 1) * sizeof(Cell);
pspacetot = 0;
for (i=0; i<NUM_CATS_SPACE; i++)
if (i != TABLE_SPACE && i != INCR_TABLE_SPACE) pspacetot += pspacesize[i];
total_alloc =
pspacetot + pspacesize[TABLE_SPACE] + pspacesize[INCR_TABLE_SPACE] +
(pdl.size + glstack.size + tcpstack.size + complstack.size) * K +
de_space_alloc + dl_space_alloc + pnde_space_alloc;
total_used =
pspacetot + pspacesize[TABLE_SPACE]-(tablespace_sm_alloc-tablespace_sm_used)
- (trieassert_alloc - trieassert_used) +
pspacesize[INCR_TABLE_SPACE] +
(glstack.size * K - gl_avail) + (tcpstack.size * K - tc_avail) +
de_space_used + dl_space_used;
switch(type) {
case TOTALMEMORY: {
ctop_int(CTXTc 4, total_alloc);
ctop_int(CTXTc 5, total_used);
break;
}
case GLMEMORY: {
ctop_int(CTXTc 4, glstack.size *K);
ctop_int(CTXTc 5, (glstack.size * K - gl_avail));
break;
}
case TCMEMORY: {
ctop_int(CTXTc 4, tcpstack.size * K);
ctop_int(CTXTc 5, (tcpstack.size * K - tc_avail));
break;
}
case TABLESPACE: {
ctop_int(CTXTc 4, private_tablespace_sm_alloc);
ctop_int(CTXTc 5, private_tablespace_sm_used);
break;
}
case TRIEASSERTMEM: {
ctop_int(CTXTc 4, trieassert_alloc);
ctop_int(CTXTc 5, trieassert_used);
break;
}
case HEAPMEM: {
ctop_int(CTXTc 4,(Integer)((top_of_heap - (CPtr)glstack.low + 1)* sizeof(Cell)));
break;
}
case CPMEM: {
ctop_int(CTXTc 4, (Integer)(((CPtr)tcpstack.high - top_of_cpstack) * sizeof(Cell)));
break;
}
case TRAILMEM: {
ctop_int(CTXTc 4, (Integer)((top_of_trail - (CPtr *)tcpstack.low + 1) * sizeof(CPtr)));
break;
}
case LOCALMEM: {
ctop_int(CTXTc 4, (Integer)(((CPtr)glstack.high - top_of_localstk) * sizeof(Cell)));
break;
}
case OPENTABLECOUNT: {
ctop_int(CTXTc 4, ((size_t)COMPLSTACKBOTTOM - (size_t)top_of_complstk) /
sizeof(struct completion_stack_frame));
ctop_int(CTXTc 5, count_sccs(CTXT));
break;
}
case SHARED_TABLESPACE: {
ctop_int(CTXTc 4, shared_tablespace_sm_alloc);
ctop_int(CTXTc 5, shared_tablespace_sm_used);
break;
}
case ATOMMEM: {
ctop_int(CTXTc 4, pspacesize[ATOM_SPACE]);
break;
}
}
}
void get_statistics(CTXTdecl) {
int type;
type = (int)ptoc_int(CTXTc 3);
switch (type) {
// runtime [since start of Prolog,since previous statistics]
// CPU time used while executing, excluding time spent
// garbage collecting, stack shifting, or in system calls.
case RUNTIME: {
double tot_cpu, incr_cpu;
tot_cpu = cpu_time();
incr_cpu = tot_cpu - last_cpu;
last_cpu = tot_cpu;
ctop_float(CTXTc 4, tot_cpu);
ctop_float(CTXTc 5, incr_cpu);
break;
}
case WALLTIME: {
double tot_wall,this_wall,incr_wall;
this_wall = real_time();
tot_wall = this_wall - realtime_count_gl;
if (!last_wall) last_wall = realtime_count_gl;
incr_wall = this_wall - last_wall;
last_wall = this_wall;
ctop_float(CTXTc 4, tot_wall);
ctop_float(CTXTc 5, incr_wall);
break;
}
case SHARED_TABLESPACE:
{
#ifdef MULTI_THREAD
get_memory_statistics(CTXTc type);
#else
xsb_abort("statistics/2 with parameter shared_tables not supported in this configuration\n");
#endif
break;
}
case IDG_COUNTS: {
ctop_int(CTXTc 4,current_call_node_count_gl);
ctop_int(CTXTc 5,current_call_edge_count_gl);
break;
}
case TABLE_OPS: {
UInteger ttl_ops = ans_chk_ins + NumSubOps_AnswerCheckInsert,
ttl_ins = ans_inserts + NumSubOps_AnswerInsert;
ctop_int(CTXTc 4,NumSubOps_CallCheckInsert);
ctop_int(CTXTc 5,NumSubOps_ProducerCall);
ctop_int(CTXTc 6,var_subg_chk_ins_gl);
ctop_int(CTXTc 7,var_subg_inserts_gl);
ctop_int(CTXTc 8,ttl_ops);
ctop_int(CTXTc 9,ttl_ins);
}
default: {
get_memory_statistics(CTXTc type);
break;
}
}
}
/*-----------------------------------------------------------------------------*/
void ODBCDataSources()
{
static SQLCHAR DSN[SQL_MAX_DSN_LENGTH+1];
static SQLCHAR Description[SQL_MAX_DSN_LENGTH+1];
RETCODE rc;
int seq;
SWORD dsn_size, descr_size;
Cell op2 = ptoc_tag(3);
Cell op3 = ptoc_tag(4);
if (!henv) {
/* allocate environment handler*/
rc = SQLAllocEnv(&henv);
if (rc != SQL_SUCCESS && rc != SQL_SUCCESS_WITH_INFO) {
xsb_error("Environment allocation failed");
ctop_int(5,1);
return;
}
LCursor = FCursor = NULL;
FCurNum = NULL;
nullStrAtom = makestring(string_find("NULL",1));
}
seq = ptoc_int(2);
if (seq == 1) {
rc = SQLDataSources(henv,SQL_FETCH_FIRST,DSN,
SQL_MAX_DSN_LENGTH,&dsn_size,
Description,SQL_MAX_DSN_LENGTH,
&descr_size);
if (rc == SQL_NO_DATA_FOUND) {
ctop_int(5,2);
return;
}
if (rc != SQL_SUCCESS && rc != SQL_SUCCESS_WITH_INFO) {
xsb_error("Environment allocation failed");
ctop_int(5,1);
return;
}
} else {
rc = SQLDataSources(henv,SQL_FETCH_NEXT,DSN,
SQL_MAX_DSN_LENGTH,&dsn_size,
Description,SQL_MAX_DSN_LENGTH,
&descr_size);
if (rc == SQL_NO_DATA_FOUND) {
ctop_int(5,2);
return;
}
if (rc != SQL_SUCCESS && rc != SQL_SUCCESS_WITH_INFO) {
xsb_error("Environment allocation failed");
ctop_int(5,1);
return;
}
}
XSB_Deref(op2);
if (isref(op2))
unify(op2, makestring(string_find(DSN,1)));
else {
xsb_error("[ODBCDataSources] Param 2 should be a free variable.");
ctop_int(5,1);
return;
}
XSB_Deref(op3);
if (isref(op3))
unify(op3, makestring(string_find(Description,1)));
else {
xsb_error("[ODBCDataSources] Param 3 should be a free variable.");
ctop_int(5,1);
return;
}
ctop_int(5,0);
return;
}
/*-----------------------------------------------------------------------------*/
void SetBindVal()
{
RETCODE rc;
struct Cursor *cur = (struct Cursor *)ptoc_int(2);
int j = ptoc_int(3);
Cell BindVal = ptoc_tag(4);
if (!((j >= 0) && (j < cur->NumBindVars)))
xsb_exit("Abnormal argument in SetBindVal!");
/* if we're reusing an opened cursor w/ the statement number*/
/* reallocate BindVar if type has changed (May not be such a good idea?)*/
if (cur->Status == 2) {
if (isinteger(BindVal)) {
if (cur->BindTypes[j] != 0) {
if (cur->BindTypes[j] != 2) free((void *)cur->BindList[j]);
cur->BindList[j] = (UCHAR *)malloc(sizeof(int));
cur->BindTypes[j] = 0;
rc = SQLBindParameter(cur->hstmt, (short)(j+1), SQL_PARAM_INPUT,
SQL_C_SLONG, SQL_INTEGER,
0, 0, (int *)(cur->BindList[j]), 0, NULL);
if (rc != SQL_SUCCESS) {
ctop_int(5,PrintErrorMsg(cur));
SetCursorClose(cur);
return;
}
}
*((int *)cur->BindList[j]) = oint_val(BindVal);
} else if (isfloat(BindVal)) {
if (cur->BindTypes[j] != 1) {
/*printf("ODBC: Changing Type: flt to %d\n",cur->BindTypes[j]);*/
if (cur->BindTypes[j] != 2) free((void *)cur->BindList[j]);
cur->BindList[j] = (UCHAR *)malloc(sizeof(float));
cur->BindTypes[j] = 1;
rc = SQLBindParameter(cur->hstmt, (short)(j+1), SQL_PARAM_INPUT,
SQL_C_FLOAT, SQL_FLOAT,
0, 0, (float *)(cur->BindList[j]), 0, NULL);
if (rc != SQL_SUCCESS) {
ctop_int(5,PrintErrorMsg(cur));
SetCursorClose(cur);
return;
}
}
*((float *)cur->BindList[j]) = (float)float_val(BindVal);
} else if (isstring(BindVal)) {
if (cur->BindTypes[j] != 2) {
/*printf("ODBC: Changing Type: str to %d\n",cur->BindTypes[j]);*/
free((void *)cur->BindList[j]);
cur->BindTypes[j] = 2;
/* SQLBindParameter will be done anyway*/
}
cur->BindList[j] = string_val(BindVal);
} else if (isconstr(BindVal) && get_arity(get_str_psc(BindVal))==1) {
letter_flag = 1;
wcan_disp = 0;
write_canonical_term(p2p_arg(BindVal,1));
if (term_string[j]) free(term_string[j]);
term_string[j] = malloc(wcan_disp+1);
strncpy(term_string[j],wcan_string,wcan_disp);
term_string[j][wcan_disp] = '\0';
cur->BindTypes[j] = 2;
cur->BindList[j] = term_string[j];
} else {
xsb_exit("Unknown bind variable type, %d", cur->BindTypes[j]);
}
ctop_int(5,0);
return;
}
/* otherwise, memory needs to be allocated in this case*/
if (isinteger(BindVal)) {
cur->BindTypes[j] = 0;
cur->BindList[j] = (UCHAR *)malloc(sizeof(int));
if (!cur->BindList[j])
xsb_exit("Not enough memory for an int in SetBindVal!");
*((int *)cur->BindList[j]) = oint_val(BindVal);
} else if (isfloat(BindVal)) {
cur->BindTypes[j] = 1;
cur->BindList[j] = (UCHAR *)malloc(sizeof(float));
if (!cur->BindList[j])
xsb_exit("Not enough memory for a float in SetBindVal!");
*((float *)cur->BindList[j]) = (float)float_val(BindVal);
} else if (isstring(BindVal)) {
cur->BindTypes[j] = 2;
cur->BindList[j] = string_val(BindVal);
} else if (isconstr(BindVal) && get_arity(get_str_psc(BindVal))==1) {
letter_flag = 1;
wcan_disp = 0;
write_canonical_term(p2p_arg(BindVal,1));
if (term_string[j]) free(term_string[j]);
term_string[j] = malloc(wcan_disp+1);
strncpy(term_string[j],wcan_string,wcan_disp);
term_string[j][wcan_disp] = '\0';
cur->BindTypes[j] = 2;
cur->BindList[j] = term_string[j];
} else {
xsb_exit("Unknown bind variable type, %d", cur->BindTypes[j]);
}
ctop_int(5,0);
return;
}
