/* .External */
SEXP ocl_call(SEXP args) {
struct arg_chain *float_args = 0;
ocl_call_context_t *occ;
int on, an = 0, ftype = FT_DOUBLE, ftsize, ftres, async;
SEXP ker = CADR(args), olen, arg, res, octx, dimVec;
cl_kernel kernel = getKernel(ker);
cl_context context;
cl_command_queue commands;
cl_device_id device_id = getDeviceID(getAttrib(ker, Rf_install("device")));
cl_mem output;
cl_int err;
size_t wdims[3] = {0, 0, 0};
int wdim = 1;
if (clGetKernelInfo(kernel, CL_KERNEL_CONTEXT, sizeof(context), &context, NULL) != CL_SUCCESS || !context)
Rf_error("cannot obtain kernel context via clGetKernelInfo");
args = CDDR(args);
res = Rf_getAttrib(ker, install("precision"));
if (TYPEOF(res) == STRSXP && LENGTH(res) == 1 && CHAR(STRING_ELT(res, 0))[0] != 'd')
ftype = FT_SINGLE;
ftsize = (ftype == FT_DOUBLE) ? sizeof(double) : sizeof(float);
olen = CAR(args); /* size */
args = CDR(args);
on = Rf_asInteger(olen);
if (on < 0)
Rf_error("invalid output length");
ftres = (Rf_asInteger(CAR(args)) == 1) ? 1 : 0; /* native.result */
if (ftype != FT_SINGLE) ftres = 0;
args = CDR(args);
async = (Rf_asInteger(CAR(args)) == 1) ? 0 : 1; /* wait */
args = CDR(args);
dimVec = coerceVector(CAR(args), INTSXP); /* dim */
wdim = LENGTH(dimVec);
if (wdim > 3)
Rf_error("OpenCL standard only supports up to three work item dimensions - use index vectors for higher dimensions");
if (wdim) {
int i; /* we don't use memcpy in case int and size_t are different */
for (i = 0; i < wdim; i++)
wdims[i] = INTEGER(dimVec)[i];
}
if (wdim < 1 || wdims[0] < 1 || (wdim > 1 && wdims[1] < 1) || (wdim > 2 && wdims[2] < 1))
Rf_error("invalid dimensions - muse be a numeric vector with positive values");
args = CDR(args);
occ = (ocl_call_context_t*) calloc(1, sizeof(ocl_call_context_t));
if (!occ) Rf_error("unable to allocate ocl_call context");
octx = PROTECT(R_MakeExternalPtr(occ, R_NilValue, R_NilValue));
R_RegisterCFinalizerEx(octx, ocl_call_context_fin, TRUE);
occ->output = output = clCreateBuffer(context, CL_MEM_WRITE_ONLY, ftsize * on, NULL, &err);
if (!output)
Rf_error("failed to create output buffer of %d elements via clCreateBuffer (%d)", on, err);
if (clSetKernelArg(kernel, an++, sizeof(cl_mem), &output) != CL_SUCCESS)
Rf_error("failed to set first kernel argument as output in clSetKernelArg");
if (clSetKernelArg(kernel, an++, sizeof(on), &on) != CL_SUCCESS)
Rf_error("failed to set second kernel argument as output length in clSetKernelArg");
occ->commands = commands = clCreateCommandQueue(context, device_id, 0, &err);
if (!commands)
ocl_err("clCreateCommandQueue");
if (ftype == FT_SINGLE) /* need conversions, create floats buffer */
occ->float_args = float_args = arg_alloc(0, 32);
while ((arg = CAR(args)) != R_NilValue) {
int n, ndiv = 1;
void *ptr;
size_t al;
switch (TYPEOF(arg)) {
case REALSXP:
if (ftype == FT_SINGLE) {
int i;
float *f;
double *d = REAL(arg);
n = LENGTH(arg);
f = (float*) malloc(sizeof(float) * n);
if (!f)
Rf_error("unable to allocate temporary single-precision memory for conversion from a double-precision argument vector of length %d", n);
for (i = 0; i < n; i++) f[i] = d[i];
ptr = f;
al = sizeof(float);
arg_add(float_args, ptr);
} else {
ptr = REAL(arg);
al = sizeof(double);
}
break;
case INTSXP:
ptr = INTEGER(arg);
al = sizeof(int);
break;
case LGLSXP:
ptr = LOGICAL(arg);
al = sizeof(int);
break;
case RAWSXP:
if (inherits(arg, "clFloat")) {
ptr = RAW(arg);
ndiv = al = sizeof(float);
break;
}
default:
Rf_error("only numeric or logical kernel arguments are supported");
/* no-ops but needed to make the compiler happy */
ptr = 0;
al = 0;
}
n = LENGTH(arg);
if (ndiv != 1) n /= ndiv;
if (n == 1) {/* scalar */
if (clSetKernelArg(kernel, an++, al, ptr) != CL_SUCCESS)
Rf_error("Failed to set scalar kernel argument %d (size=%d)", an, al);
} else {
cl_mem input = clCreateBuffer(context, CL_MEM_READ_ONLY | CL_MEM_USE_HOST_PTR, al * n, ptr, &err);
if (!input)
Rf_error("Unable to create buffer (%d elements, %d bytes each) for vector argument %d (oclError %d)", n, al, an, err);
if (!occ->mem_objects)
occ->mem_objects = arg_alloc(0, 32);
arg_add(occ->mem_objects, input);
#if 0 /* we used this before CL_MEM_USE_HOST_PTR */
if (clEnqueueWriteBuffer(commands, input, CL_TRUE, 0, al * n, ptr, 0, NULL, NULL) != CL_SUCCESS)
Rf_error("Failed to transfer data (%d elements) for vector argument %d", n, an);
#endif
if (clSetKernelArg(kernel, an++, sizeof(cl_mem), &input) != CL_SUCCESS)
Rf_error("Failed to set vector kernel argument %d (size=%d, length=%d)", an, al, n);
/* clReleaseMemObject(input); */
}
args = CDR(args);
}
if (clEnqueueNDRangeKernel(commands, kernel, wdim, NULL, wdims, NULL, 0, NULL, async ? &occ->event : NULL) != CL_SUCCESS)
Rf_error("Error during kernel execution");
if (async) { /* asynchronous call -> get out and return the context */
#if USE_OCL_COMPLETE_CALLBACK
clSetEventCallback(occ->event, CL_COMPLETE, ocl_complete_callback, occ);
#endif
clFlush(commands); /* the specs don't guarantee execution unless clFlush is called */
occ->ftres = ftres;
occ->ftype = ftype;
occ->on = on;
Rf_setAttrib(octx, R_ClassSymbol, mkString("clCallContext"));
UNPROTECT(1);
return octx;
}
clFinish(commands);
occ->finished = 1;
/* we can release input memory objects now */
if (occ->mem_objects) {
arg_free(occ->mem_objects, (afin_t) clReleaseMemObject);
occ->mem_objects = 0;
}
if (float_args) {
arg_free(float_args, 0);
float_args = occ->float_args = 0;
}
res = ftres ? Rf_allocVector(RAWSXP, on * sizeof(float)) : Rf_allocVector(REALSXP, on);
if (ftype == FT_SINGLE) {
if (ftres) {
if ((err = clEnqueueReadBuffer( commands, output, CL_TRUE, 0, sizeof(float) * on, RAW(res), 0, NULL, NULL )) != CL_SUCCESS)
Rf_error("Unable to transfer result vector (%d float elements, oclError %d)", on, err);
PROTECT(res);
Rf_setAttrib(res, R_ClassSymbol, mkString("clFloat"));
UNPROTECT(1);
} else {
/* float - need a temporary buffer */
float *fr = (float*) malloc(sizeof(float) * on);
double *r = REAL(res);
int i;
if (!fr)
Rf_error("unable to allocate memory for temporary single-precision output buffer");
occ->float_out = fr;
if ((err = clEnqueueReadBuffer( commands, output, CL_TRUE, 0, sizeof(float) * on, fr, 0, NULL, NULL )) != CL_SUCCESS)
Rf_error("Unable to transfer result vector (%d float elements, oclError %d)", on, err);
for (i = 0; i < on; i++)
r[i] = fr[i];
}
} else if ((err = clEnqueueReadBuffer( commands, output, CL_TRUE, 0, sizeof(double) * on, REAL(res), 0, NULL, NULL )) != CL_SUCCESS)
Rf_error("Unable to transfer result vector (%d double elements, oclError %d)", on, err);
ocl_call_context_fin(octx);
UNPROTECT(1);
return res;
}
SEXP
RGDAL_OpenDataset(SEXP filename, SEXP read_only, SEXP silent, SEXP allowedDr, SEXP sOpts) {
const char *fn = asString(filename);
#ifdef GDALV2
int i;
char **papszOpenOptions = NULL;
char **papszAllowedDrivers = NULL;
installErrorHandler();
for (i=0; i < length(sOpts); i++) papszOpenOptions = CSLAddString(
papszOpenOptions, CHAR(STRING_ELT(sOpts, i)) );
for (i=0; i < CSLCount(papszOpenOptions); i++)
Rprintf("option %d: %s\n", i, CSLGetField(papszOpenOptions, i));
uninstallErrorHandlerAndTriggerError();
installErrorHandler();
for (i=0; i < length(allowedDr); i++) papszAllowedDrivers = CSLAddString(
papszAllowedDrivers, CHAR(STRING_ELT(allowedDr, i)) );
for (i=0; i < CSLCount(papszAllowedDrivers); i++)
Rprintf("driver %d: %s\n", i, CSLGetField(papszAllowedDrivers, i));
uninstallErrorHandlerAndTriggerError();
#endif
#ifdef GDALV2
unsigned int RWFlag;
if (asLogical(read_only))
RWFlag = GDAL_OF_RASTER | GDAL_OF_READONLY;
else
RWFlag = GDAL_OF_RASTER | GDAL_OF_UPDATE;
#else
GDALAccess RWFlag;
if (asLogical(read_only))
RWFlag = GA_ReadOnly;
else
RWFlag = GA_Update;
#endif
/* Modification suggested by Even Rouault, 2009-08-08: */
CPLErrorReset();
if (asLogical(silent))
CPLPushErrorHandler(CPLQuietErrorHandler);
else
installErrorHandler();
#ifdef GDALV2
GDALDataset *pDataset = (GDALDataset *) GDALOpenEx(fn, RWFlag,
papszAllowedDrivers, papszOpenOptions, NULL);
#else
GDALDataset *pDataset = (GDALDataset *) GDALOpen(fn, RWFlag);
#endif
if (pDataset == NULL)
error("%s\n", CPLGetLastErrorMsg());
if (asLogical(silent))
CPLPopErrorHandler();
else
uninstallErrorHandlerAndTriggerError();
#ifdef GDALV2
installErrorHandler();
CSLDestroy(papszOpenOptions);
CSLDestroy(papszAllowedDrivers);
uninstallErrorHandlerAndTriggerError();
#endif
/* Similarly to SWIG bindings, the following lines will cause
RGDAL_OpenDataset() to fail on - uncleared - errors even if pDataset is not
NULL. They could also be just removed. While pDataset != NULL, there's some
hope ;-) */
/* CPLErr eclass = CPLGetLastErrorType();
if (pDataset != NULL && eclass == CE_Failure) {
GDALClose(pDataset);
pDataset = NULL;
__errorHandler(eclass, CPLGetLastErrorNo(), CPLGetLastErrorMsg());
}*/
SEXP sxpHandle = R_MakeExternalPtr((void *) pDataset,
mkChar("GDAL Dataset"),
R_NilValue);
return(sxpHandle);
}
static SEXP protected_args(struct arg_chain *chain, afin_t fin) {
SEXP res = R_MakeExternalPtr(chain, R_NilValue, R_NilValue);
chain->fin = fin;
R_RegisterCFinalizerEx(res, free_protected_args, TRUE);
return res;
}
SEXP Rhpc_gethandle(SEXP procs)
{
int num_procs;
MPI_Comm *ptr;
SEXP com;
int num;
MPI_Comm pcomm;
if (RHPC_Comm == MPI_COMM_NULL){
error("Rhpc_initialize is not called.");
return(R_NilValue);
}
if(finalize){
warning("Rhpc were already finalized.");
return(R_NilValue);
}
if(!initialize){
warning("Rhpc not initialized.");
return(R_NilValue);
}
num_procs = INTEGER (procs)[0];
ptr = Calloc(1,MPI_Comm);
PROTECT(com = R_MakeExternalPtr(ptr, R_NilValue, R_NilValue));
R_RegisterCFinalizer(com, comm_free);
SXP2COMM(com) = RHPC_Comm;
if (num_procs == NA_INTEGER){/* use mpirun */
_M(MPI_Comm_size(SXP2COMM(com), &num));
Rprintf("Detected communication size %d\n", num);
if( num > 1 ){
if ( num_procs > 0){
warning("blind procs argument, return of MPI_COMM_WORLD");
}
}else{
if ( num == 1){
warning("only current master process. not found worker process.");
}
SXP2COMM(com)=MPI_COMM_NULL;
warning("please pecifies the number of processes in mpirun or mpiexec, or provide a number of process to spawn");
}
UNPROTECT(1);
return(com);
}else{ /* spawn */
if(num_procs < 1){
warning("you need positive number of procs argument");
UNPROTECT(1);
return(com);
}
_M(MPI_Comm_size(SXP2COMM(com), &num));
if(num > 1){
warning("blind procs argument, return of last communicator");
UNPROTECT(1);
return(com);
}
}
_M(MPI_Comm_spawn(RHPC_WORKER_CMD, MPI_ARGV_NULL, num_procs,
MPI_INFO_NULL, 0, MPI_COMM_SELF, &pcomm,
MPI_ERRCODES_IGNORE));
_M(MPI_Intercomm_merge( pcomm, 0, SXP2COMMP(com)));
_M(MPI_Comm_free( &pcomm ));
_M(MPI_Comm_size(SXP2COMM(com), &num));
RHPC_Comm = SXP2COMM(com); /* rewrite RHPC_Comm */
_M(MPI_Comm_set_errhandler(RHPC_Comm, MPI_ERRORS_RETURN));
_M(MPI_Comm_rank(RHPC_Comm, &MPI_rank));
_M(MPI_Comm_size(RHPC_Comm, &MPI_procs));
DPRINT("Rhpc_getHandle(MPI_Comm_spawn : rank:%d size:%d\n", MPI_rank, MPI_procs);
Rhpc_set_options( MPI_rank, MPI_procs,RHPC_Comm);
UNPROTECT(1);
return(com);
}
SEXP R_MakeExternalPtrFn(DL_FUNC p, SEXP tag, SEXP prot) {
fn_ptr ptr;
ptr.fn = p;
return R_MakeExternalPtr(ptr.p, tag, prot);
}
SEXP derefPtr(SEXP SmultiPtr) {
void **doublePtr = static_cast<void **>(R_ExternalPtrAddr(SmultiPtr));
return(R_MakeExternalPtr( static_cast<void *>(*doublePtr), R_NilValue, R_NilValue) );
}
SEXP r_strptr(SEXP x)
{
return R_MakeExternalPtr( (void*) CHAR(STRING_ELT(x, 0)), R_NilValue, x );
}
SEXP ScalarPointer(void*ptr,SEXP tag,void (*fin)(SEXP)) {
SEXP ret = R_MakeExternalPtr(ptr,tag,R_NilValue);
if(fin != NULL)
R_RegisterCFinalizerEx(ret,fin,1);
return ret;
}
/* A generic recv wrapper function */
SEXP SOCK_RECV(SEXP S, SEXP EXT, SEXP BS, SEXP MAXBUFSIZE)
{
SEXP ans = R_NilValue;
void *buf;
char *msg, *p;
// struct pollfd pfds;
int j, s = INTEGER(S)[0];
size_t k = 0;
double maxbufsize = REAL(MAXBUFSIZE)[0];
int bufsize = MBUF;
int bs = INTEGER(BS)[0];
if(maxbufsize < bs) maxbufsize = bs;
buf = (void *)malloc(bs);
msg = (char *)malloc(bs);
p = msg;
// pfds.fd = s;
// pfds.events = POLLIN;
// h = poll(&pfds, 1, 50);
// while(h>0) {
j = 1;
while(j>=0) {
#ifdef WIN32
j = recv((SOCKET)s, buf, bs, 0);
#else
j = recv(s, buf, bs, 0);
#endif
if(j<1) break;
/* If we exceed the maxbufsize, break. This leaves data
* in the TCP RX buffer. XXX We need to tell R that this
* is an incomplete read so this can be handled at a high
* level, for example by closing the connection or whatever.
* The code is here for basic protection from DoS and memory
* overcommit attacks.
*/
if(k+j > maxbufsize) break;
if(k + j > bufsize) {
bufsize = bufsize + MBUF;
msg = (char *)realloc(msg, bufsize);
}
p = msg + k;
memcpy((void *)p, buf, j);
k = k + j;
// h=poll(&pfds, 1, 50);
}
if(INTEGER(EXT)[0]) {
/* return a pointer to the recv buffer */
ans = R_MakeExternalPtr ((void *)msg, R_NilValue, R_NilValue);
R_RegisterCFinalizer (ans, recv_finalize);
free(buf);
}
else {
/* Copy to a raw vector */
PROTECT(ans=allocVector(RAWSXP,k));
p = (char *)RAW(ans);
memcpy((void *)p, (void *)msg, k);
free(buf);
free(msg);
UNPROTECT(1);
}
return ans;
}
SEXP wrapped_apop_data_from_frame(SEXP in){
apop_data *outdata = apop_data_from_frame(in);
printf("Now wrapping:\n");
apop_data_print(outdata);
return R_MakeExternalPtr(outdata, NULL, NULL);
}
/*
* Takes the prepared plan rsaved_plan and creates a cursor
* for it using the values specified in ragvalues.
*
*/
SEXP
plr_SPI_cursor_open(SEXP cursor_name_arg,SEXP rsaved_plan, SEXP rargvalues)
{
saved_plan_desc *plan_desc = (saved_plan_desc *) R_ExternalPtrAddr(rsaved_plan);
void *saved_plan = plan_desc->saved_plan;
int nargs = plan_desc->nargs;
Oid *typeids = plan_desc->typeids;
FmgrInfo *typinfuncs = plan_desc->typinfuncs;
int i;
Datum *argvalues = NULL;
char *nulls = NULL;
bool isnull = false;
SEXP obj;
SEXP result = NULL;
MemoryContext oldcontext;
char cursor_name[64];
Portal portal=NULL;
PREPARE_PG_TRY;
PUSH_PLERRCONTEXT(rsupport_error_callback, "pg.spi.cursor_open");
/* Divide rargvalues */
if (nargs > 0)
{
if (!Rf_isVectorList(rargvalues))
error("%s", "second parameter must be a list of arguments " \
"to the prepared plan");
if (length(rargvalues) != nargs)
error("list of arguments (%d) is not the same length " \
"as that of the prepared plan (%d)",
length(rargvalues), nargs);
argvalues = (Datum *) palloc(nargs * sizeof(Datum));
nulls = (char *) palloc(nargs * sizeof(char));
}
for (i = 0; i < nargs; i++)
{
PROTECT(obj = VECTOR_ELT(rargvalues, i));
argvalues[i] = get_scalar_datum(obj, typeids[i], typinfuncs[i], &isnull);
if (!isnull)
nulls[i] = ' ';
else
nulls[i] = 'n';
UNPROTECT(1);
}
strncpy(cursor_name, CHAR(STRING_ELT(cursor_name_arg,0)), 64);
/* switch to SPI memory context */
SWITCHTO_PLR_SPI_CONTEXT(oldcontext);
/*
* trap elog/ereport so we can let R finish up gracefully
* and generate the error once we exit the interpreter
*/
PG_TRY();
{
/* Open the cursor */
portal = SPI_cursor_open(cursor_name,saved_plan, argvalues, nulls,1);
}
PLR_PG_CATCH();
PLR_PG_END_TRY();
/* back to caller's memory context */
MemoryContextSwitchTo(oldcontext);
if(portal==NULL)
error("SPI_cursor_open() failed");
else
result = R_MakeExternalPtr(portal, R_NilValue, R_NilValue);
POP_PLERRCONTEXT;
return result;
}
/*
* plr_SPI_prepare - The builtin SPI_prepare command for the R interpreter
*/
SEXP
plr_SPI_prepare(SEXP rsql, SEXP rargtypes)
{
const char *sql;
int nargs;
int i;
Oid *typeids = NULL;
Oid *typelems = NULL;
FmgrInfo *typinfuncs = NULL;
void *pplan = NULL;
void *saved_plan;
saved_plan_desc *plan_desc;
SEXP result;
MemoryContext oldcontext;
PREPARE_PG_TRY;
/* set up error context */
PUSH_PLERRCONTEXT(rsupport_error_callback, "pg.spi.prepare");
/* switch to long lived context to create plan description */
oldcontext = MemoryContextSwitchTo(TopMemoryContext);
plan_desc = (saved_plan_desc *) palloc(sizeof(saved_plan_desc));
MemoryContextSwitchTo(oldcontext);
PROTECT(rsql = AS_CHARACTER(rsql));
sql = CHAR(STRING_ELT(rsql, 0));
UNPROTECT(1);
if (sql == NULL)
error("%s", "cannot prepare empty query");
PROTECT(rargtypes = AS_INTEGER(rargtypes));
if (!isVector(rargtypes) || !isInteger(rargtypes))
error("%s", "second parameter must be a vector of PostgreSQL datatypes");
/* deal with case of no parameters for the prepared query */
if (rargtypes == R_MissingArg || INTEGER(rargtypes)[0] == NA_INTEGER)
nargs = 0;
else
nargs = length(rargtypes);
if (nargs < 0) /* can this even happen?? */
error("%s", "second parameter must be a vector of PostgreSQL datatypes");
if (nargs > 0)
{
/* switch to long lived context to create plan description elements */
oldcontext = MemoryContextSwitchTo(TopMemoryContext);
typeids = (Oid *) palloc(nargs * sizeof(Oid));
typelems = (Oid *) palloc(nargs * sizeof(Oid));
typinfuncs = (FmgrInfo *) palloc(nargs * sizeof(FmgrInfo));
MemoryContextSwitchTo(oldcontext);
for (i = 0; i < nargs; i++)
{
int16 typlen;
bool typbyval;
char typdelim;
Oid typinput,
typelem;
char typalign;
FmgrInfo typinfunc;
typeids[i] = INTEGER(rargtypes)[i];
/* switch to long lived context to create plan description elements */
oldcontext = MemoryContextSwitchTo(TopMemoryContext);
get_type_io_data(typeids[i], IOFunc_input, &typlen, &typbyval,
&typalign, &typdelim, &typelem, &typinput);
typelems[i] = get_element_type(typeids[i]);
MemoryContextSwitchTo(oldcontext);
/* perm_fmgr_info already uses TopMemoryContext */
perm_fmgr_info(typinput, &typinfunc);
typinfuncs[i] = typinfunc;
}
}
else
typeids = NULL;
UNPROTECT(1);
/* switch to SPI memory context */
SWITCHTO_PLR_SPI_CONTEXT(oldcontext);
/*
* trap elog/ereport so we can let R finish up gracefully
* and generate the error once we exit the interpreter
*/
PG_TRY();
{
/* Prepare plan for query */
pplan = SPI_prepare(sql, nargs, typeids);
}
PLR_PG_CATCH();
PLR_PG_END_TRY();
if (pplan == NULL)
{
char buf[128];
char *reason;
switch (SPI_result)
{
case SPI_ERROR_ARGUMENT:
reason = "SPI_ERROR_ARGUMENT";
break;
case SPI_ERROR_UNCONNECTED:
reason = "SPI_ERROR_UNCONNECTED";
break;
case SPI_ERROR_COPY:
reason = "SPI_ERROR_COPY";
break;
case SPI_ERROR_CURSOR:
reason = "SPI_ERROR_CURSOR";
break;
case SPI_ERROR_TRANSACTION:
reason = "SPI_ERROR_TRANSACTION";
break;
case SPI_ERROR_OPUNKNOWN:
reason = "SPI_ERROR_OPUNKNOWN";
break;
default:
snprintf(buf, sizeof(buf), "unknown RC %d", SPI_result);
reason = buf;
break;
}
/* internal error */
error("SPI_prepare() failed: %s", reason);
}
/* SPI_saveplan already uses TopMemoryContext */
saved_plan = SPI_saveplan(pplan);
if (saved_plan == NULL)
{
char buf[128];
char *reason;
switch (SPI_result)
{
case SPI_ERROR_ARGUMENT:
reason = "SPI_ERROR_ARGUMENT";
break;
case SPI_ERROR_UNCONNECTED:
reason = "SPI_ERROR_UNCONNECTED";
break;
default:
snprintf(buf, sizeof(buf), "unknown RC %d", SPI_result);
reason = buf;
break;
}
/* internal error */
error("SPI_saveplan() failed: %s", reason);
}
/* back to caller's memory context */
MemoryContextSwitchTo(oldcontext);
/* no longer need this */
SPI_freeplan(pplan);
plan_desc->saved_plan = saved_plan;
plan_desc->nargs = nargs;
plan_desc->typeids = typeids;
plan_desc->typelems = typelems;
plan_desc->typinfuncs = typinfuncs;
result = R_MakeExternalPtr(plan_desc, R_NilValue, R_NilValue);
POP_PLERRCONTEXT;
return result;
}
SEXP RS_connect(SEXP sHost, SEXP sPort, SEXP useTLS, SEXP sProxyTarget, SEXP sProxyWait) {
int port = asInteger(sPort), use_tls = (asInteger(useTLS) == 1), px_get_slot = (asInteger(sProxyWait) == 0);
const char *host;
char idstr[32];
rsconn_t *c;
SEXP res, caps = R_NilValue;
if (port < 0 || port > 65534)
Rf_error("Invalid port number");
#ifdef WIN32
if (!port)
Rf_error("unix sockets are not supported in Windows");
#endif
#ifndef USE_TLS
if (use_tls)
Rf_error("TLS is not supported in this build - recompile with OpenSSL");
#endif
if (sHost == R_NilValue && !port)
Rf_error("socket name must be specified in socket mode");
if (sHost == R_NilValue)
host = "127.0.0.1";
else {
if (TYPEOF(sHost) != STRSXP || LENGTH(sHost) != 1)
Rf_error("host must be a character vector of length one");
host = R2UTF8(sHost);
}
c = rsc_connect(host, port);
if (!c)
Rf_error("cannot connect to %s:%d", host, port);
#ifdef USE_TLS
if (use_tls && tls_upgrade(c) != 1) {
rsc_close(c);
Rf_error("TLS handshake failed");
}
#endif
if (rsc_read(c, idstr, 32) != 32) {
rsc_close(c);
Rf_error("Handshake failed - ID string not received");
}
if (!memcmp(idstr, "RSpx", 4) && !memcmp(idstr + 8, "QAP1", 4)) { /* RSpx proxy protocol */
const char *proxy_target;
struct phdr hdr;
if (TYPEOF(sProxyTarget) != STRSXP || LENGTH(sProxyTarget) < 1) {
rsc_close(c);
Rf_error("Connected to a non-transparent proxy, but no proxy target was specified");
}
/* send CMD_PROXY_TARGET and re-fetch ID string */
proxy_target = CHAR(STRING_ELT(sProxyTarget, 0));
hdr.cmd = itop(CMD_PROXY_TARGET);
hdr.len = itop(strlen(proxy_target) + 1);
hdr.dof = 0;
hdr.res = 0;
rsc_write(c, &hdr, sizeof(hdr));
rsc_write(c, proxy_target, strlen(proxy_target) + 1);
if (px_get_slot) { /* send CMD_PROXY_GET_SLOT as well if requested */
hdr.cmd = itop(CMD_PROXY_GET_SLOT);
hdr.len = 0;
rsc_write(c, &hdr, sizeof(hdr));
}
rsc_flush(c);
if (rsc_read(c, idstr, 32) != 32) {
rsc_close(c);
Rf_error("Handshake failed - ID string not received (after CMD_PROXY_TARGET)");
}
}
/* OC mode */
if (((const int*)idstr)[0] == itop(CMD_OCinit)) {
int sb_len;
struct phdr *hdr = (struct phdr *) idstr;
hdr->len = itop(hdr->len);
if (hdr->res || hdr->dof || hdr->len > sizeof(slurp_buffer) || hdr->len < 16) {
rsc_close(c);
Rf_error("Handshake failed - invalid RsOC OCinit message");
}
sb_len = 32 - sizeof(struct phdr);
memcpy(slurp_buffer, idstr + sizeof(struct phdr), sb_len);
if (rsc_read(c, slurp_buffer + sb_len, hdr->len - sb_len) != hdr->len - sb_len) {
rsc_close(c);
Rf_error("Handshake failed - truncated RsOC OCinit message");
} else {
unsigned int *ibuf = (unsigned int*) slurp_buffer;
int par_type = PAR_TYPE(*ibuf);
int is_large = (par_type & DT_LARGE) ? 1 : 0;
if (is_large) par_type ^= DT_LARGE;
if (par_type != DT_SEXP) {
rsc_close(c);
Rf_error("Handshake failed - invalid payload in OCinit message");
}
ibuf += is_large + 1;
caps = QAP_decode(&ibuf);
if (caps != R_NilValue)
PROTECT(caps);
}
} else {
if (memcmp(idstr, "Rsrv", 4) || memcmp(idstr + 8, "QAP1", 4)) {
rsc_close(c);
Rf_error("Handshake failed - unknown protocol");
}
/* supported range 0100 .. 0103 */
if (memcmp(idstr + 4, "0100", 4) < 0 || memcmp(idstr + 4, "0103", 4) > 0) {
rsc_close(c);
Rf_error("Handshake failed - server protocol version too high");
}
}
res = PROTECT(R_MakeExternalPtr(c, R_NilValue, R_NilValue));
setAttrib(res, R_ClassSymbol, mkString("RserveConnection"));
R_RegisterCFinalizer(res, rsconn_fin);
if (caps != R_NilValue) {
setAttrib(res, install("capabilities"), caps);
UNPROTECT(1);
}
UNPROTECT(1);
return res;
}
SEXP FFI_TypeCodePointer(SEXP s) {
/* Make sure its a typecode */
s = FFI_asTypeCode(s);
return R_MakeExternalPtr(&ffi_type_pointer,FFI_TypeTag,s);
}
