/* .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); }