static void audio_instance_destructor(SEXP instance) {
audio_instance_t *p = (audio_instance_t *) EXTPTR_PTR(instance);
p->driver->close(p);
p->driver->dispose(p); /* it's driver's responsibility to dispose p */
}
SEXP rph_gff_dataframe(SEXP gffPtr) {
GFF_Set *gff;
GFF_Feature *feat;
SEXP result, names, src, feature, start, end, score, strand, frame, attribute, header;
int i, len, listlen, *intp;
double *doublep;
char strandStr[2];
//first five columns are required; others may not be defined
char gffCols[9][20] = {"seqname", "src", "feature", "start", "end", "score", "strand", "frame", "attribute"};
int have[9] = {1, 1, 1, 1, 1, 0, 0, 0, 0};
int scorePos = 5, strandPos = 6, framePos = 7, attributePos = 8;
SEXP vec[9];
gff = (GFF_Set*)EXTPTR_PTR(gffPtr);
gff_register_protect(gff);
len = lst_size(gff->features);
//first five columns are required: name, src, feature, start, end
PROTECT(names = allocVector(STRSXP, len));
for (i=0; i<len; i++) {
feat = (GFF_Feature*)lst_get_ptr(gff->features, i);
SET_STRING_ELT(names, i, mkChar(feat->seqname->chars));
}
vec[0] = names;
checkInterrupt();
PROTECT(src = allocVector(STRSXP, len));
for (i=0; i<len; i++) {
feat = (GFF_Feature*)lst_get_ptr(gff->features, i);
SET_STRING_ELT(src, i, mkChar(feat->source->chars));
}
vec[1] = src;
checkInterrupt();
PROTECT(feature=allocVector(STRSXP, len));
for (i=0; i<len; i++) {
feat = (GFF_Feature*)lst_get_ptr(gff->features, i);
SET_STRING_ELT(feature, i, mkChar(feat->feature->chars));
}
vec[2] = feature;
checkInterrupt();
PROTECT(start=NEW_INTEGER(len));
intp = INTEGER_POINTER(start);
for (i=0; i<len; i++) {
feat = (GFF_Feature*)lst_get_ptr(gff->features, i);
intp[i] = feat->start;
}
vec[3] = start;
checkInterrupt();
PROTECT(end = NEW_INTEGER(len));
intp = INTEGER_POINTER(end);
for (i=0; i<len; i++) {
feat = (GFF_Feature*)lst_get_ptr(gff->features, i);
intp[i] = feat->end;
}
vec[4] = end;
checkInterrupt();
PROTECT(score = NEW_NUMERIC(len));
doublep = NUMERIC_POINTER(score);
for (i=0; i<len; i++) {
feat = (GFF_Feature*)lst_get_ptr(gff->features, i);
if (feat->score_is_null)
doublep[i] = NA_REAL; //may have to include R_ext/Arith.h
else {
doublep[i] = feat->score;
have[scorePos] = 1;
}
}
vec[5] = score;
checkInterrupt();
PROTECT(strand = allocVector(STRSXP, len));
strandStr[1] = '\0';
for (i=0; i<len; i++) {
feat = (GFF_Feature*)lst_get_ptr(gff->features, i);
strandStr[0] = feat->strand;
SET_STRING_ELT(strand, i, mkChar(strandStr));
if (feat->strand != '.')
have[strandPos] = 1;
}
vec[6] = strand;
checkInterrupt();
PROTECT(frame = NEW_INTEGER(len));
intp = INTEGER_POINTER(frame);
for (i=0; i<len; i++) {
feat = (GFF_Feature*)lst_get_ptr(gff->features, i);
if (feat->frame == GFF_NULL_FRAME)
intp[i] = NA_INTEGER;
else {
have[framePos] = 1;
intp[i] = feat->frame;
if (feat->frame == 0)
intp[i] = 0;
else if (feat->frame==1)
intp[i] = 2;
else if (feat->frame==2)
intp[i] = 1;
else die("invalid frame %i in GFF", feat->frame);
}
}
vec[7] = frame;
checkInterrupt();
PROTECT(attribute = allocVector(STRSXP, len));
for (i=0; i<len; i++) {
feat = (GFF_Feature*)lst_get_ptr(gff->features, i);
//suspect mkChar is not dealing well with empty string?
// SET_STRING_ELT(attribute, i, mkChar(feat->attribute->chars));
if (feat->attribute->length != 0) {
have[attributePos] = 1;
SET_STRING_ELT(attribute, i, mkChar(feat->attribute->chars));
} else
SET_STRING_ELT(attribute, i, mkChar("."));
}
vec[8] = attribute;
checkInterrupt();
listlen = 0;
for (i=0; i<9; i++) listlen += have[i];
PROTECT(header = allocVector(STRSXP, listlen));
PROTECT(result = allocVector(VECSXP, listlen));
listlen = 0;
for (i=0; i<9; i++) {
if (have[i]) {
SET_STRING_ELT(header, listlen, mkChar(gffCols[i]));
SET_VECTOR_ELT(result, listlen++, vec[i]);
}
}
SET_NAMES(result, header);
UNPROTECT(11);
return result;
}
DL_FUNC R_ExternalPtrAddrFn(SEXP s) {
fn_ptr ptr;
ptr.p = EXTPTR_PTR(s);
return ptr.fn;
}
SEXP rph_gff_one_attribute(SEXP gffP, SEXP tagP) {
GFF_Set *gff = (GFF_Set*)EXTPTR_PTR(gffP);
GFF_Feature *f;
ListOfLists *lol;
List *l1, *l2;
int numtag, numval, i, j, k, resultLen, maxResultLen=10;
String *currStr, *tag, *currTag;
char **result;
SEXP rv;
SEXP rph_listOfLists_to_SEXP(ListOfLists *lol);
if (lst_size(gff->features) == 0) return R_NilValue;
gff_register_protect(gff);
result = smalloc(maxResultLen*sizeof(char*));
tag = str_new_charstr(CHARACTER_VALUE(tagP));
str_double_trim(tag);
lol = lol_new(lst_size(gff->features));
l1 = lst_new_ptr(10);
l2 = lst_new_ptr(10);
for (i=0; i < lst_size(gff->features); i++) {
checkInterruptN(i, 1000);
resultLen=0;
f = (GFF_Feature*) lst_get_ptr(gff->features, i);
numtag = str_split_with_quotes(f->attribute, ";", l1); //split tags
for (j=0; j < numtag; j++) {
currStr = (String*)lst_get_ptr(l1, j);
str_double_trim(currStr);
//first try gff version 3, see if we have tag=val format
numval = str_split_with_quotes(currStr, "=", l2);
if (numval == 2) {
currTag = (String*)lst_get_ptr(l2, 0);
str_double_trim(currTag);
if (str_equals(tag, currTag)) { // tag matches target, add all values to list
currStr = str_new_charstr(((String*)lst_get_ptr(l2, 1))->chars);
lst_free_strings(l2);
numval = str_split_with_quotes(currStr, ",", l2);
str_free(currStr);
for (k=0; k < numval; k++) {
currStr = lst_get_ptr(l2, k);
str_double_trim(currStr);
str_remove_quotes(currStr);
if (resultLen > maxResultLen) {
maxResultLen += 100;
result = srealloc(result, maxResultLen*sizeof(char*));
}
result[resultLen++] = copy_charstr(currStr->chars);
}
}
} else {
lst_free_strings(l2);
//gff version 2
//split into tag val val ... by whitespace unless enclosed in quotes
numval = str_split_with_quotes(currStr, NULL, l2);
if (numval > 1) {
currStr = (String*)lst_get_ptr(l2, 0);
str_double_trim(currStr);
if (str_equals(tag, currStr)) { //tag matches target, add all values to list
for (k=1; k < numval; k++) {
currStr = (String*)lst_get_ptr(l2, k);
str_double_trim(currStr);
str_remove_quotes(currStr);
if (resultLen > maxResultLen) {
maxResultLen += 100;
result = srealloc(result, maxResultLen*sizeof(char*));
}
result[resultLen++] = copy_charstr(currStr->chars);
}
}
}
lst_free_strings(l2);
}
}
if (resultLen == 0)
result[resultLen++] = copy_charstr(""); //empty string will be converted to NA later
lol_push_charvec(lol, result, resultLen, NULL);
for (j=0; j < resultLen; j++) sfree(result[j]);
}
PROTECT(rv = rph_listOfLists_to_SEXP(lol));
UNPROTECT(1);
return rv;
}
SEXP rph_gff_copy(SEXP gffP) {
return rph_gff_new_extptr(gff_copy_set_no_groups((GFF_Set*)EXTPTR_PTR(gffP)));
}
SEXP rph_cm_new_from_gff(SEXP gff) {
return rph_cm_new_extptr(cm_new_from_features((GFF_Set*)EXTPTR_PTR(gff)));
}
void rph_gff_free(SEXP gffPtr) {
GFF_Set *gff = (GFF_Set*)EXTPTR_PTR(gffPtr);
phast_unregister_protected(gff);
gff_free_set(gff);
}
/* do the two objects compute as identical?
Also used in unique.c */
Rboolean
R_compute_identical(SEXP x, SEXP y, int flags)
{
SEXP ax, ay, atrx, atry;
if(x == y) /* same pointer */
return TRUE;
if(TYPEOF(x) != TYPEOF(y))
return FALSE;
if(OBJECT(x) != OBJECT(y))
return FALSE;
/* Skip attribute checks for CHARSXP
-- such attributes are used for the cache. */
if(TYPEOF(x) == CHARSXP)
{
/* This matches NAs */
return Seql(x, y);
}
ax = ATTRIB(x); ay = ATTRIB(y);
if (!ATTR_AS_SET) {
if(!R_compute_identical(ax, ay, flags)) return FALSE;
}
/* Attributes are special: they should be tagged pairlists. We
don't test them if they are not, and we do not test the order
if they are.
This code is not very efficient, but then neither is using
pairlists for attributes. If long attribute lists become more
common (and they are used for S4 slots) we should store them in
a hash table.
*/
else if(ax != R_NilValue || ay != R_NilValue) {
if(ax == R_NilValue || ay == R_NilValue)
return FALSE;
if(TYPEOF(ax) != LISTSXP || TYPEOF(ay) != LISTSXP) {
warning(_("ignoring non-pairlist attributes"));
} else {
SEXP elx, ely;
if(length(ax) != length(ay)) return FALSE;
/* They are the same length and should have
unique non-empty non-NA tags */
for(elx = ax; elx != R_NilValue; elx = CDR(elx)) {
const char *tx = CHAR(PRINTNAME(TAG(elx)));
for(ely = ay; ely != R_NilValue; ely = CDR(ely))
if(streql(tx, CHAR(PRINTNAME(TAG(ely))))) {
/* We need to treat row.names specially here */
if(streql(tx, "row.names")) {
PROTECT(atrx = getAttrib(x, R_RowNamesSymbol));
PROTECT(atry = getAttrib(y, R_RowNamesSymbol));
if(!R_compute_identical(atrx, atry, flags)) {
UNPROTECT(2);
return FALSE;
} else
UNPROTECT(2);
} else
if(!R_compute_identical(CAR(elx), CAR(ely), flags))
return FALSE;
break;
}
if(ely == R_NilValue) return FALSE;
}
}
}
switch (TYPEOF(x)) {
case NILSXP:
return TRUE;
case LGLSXP:
if (length(x) != length(y)) return FALSE;
/* Use memcmp (which is ISO C90) to speed up the comparison */
return memcmp((void *)LOGICAL(x), (void *)LOGICAL(y),
length(x) * sizeof(int)) == 0 ? TRUE : FALSE;
case INTSXP:
if (length(x) != length(y)) return FALSE;
/* Use memcmp (which is ISO C90) to speed up the comparison */
return memcmp((void *)INTEGER(x), (void *)INTEGER(y),
length(x) * sizeof(int)) == 0 ? TRUE : FALSE;
case REALSXP:
{
int n = length(x);
if(n != length(y)) return FALSE;
else {
double *xp = REAL(x), *yp = REAL(y);
int i, ne_strict = NUM_EQ | (SINGLE_NA << 1);
for(i = 0; i < n; i++)
if(neWithNaN(xp[i], yp[i], ne_strict)) return FALSE;
}
return TRUE;
}
case CPLXSXP:
{
int n = length(x);
if(n != length(y)) return FALSE;
else {
Rcomplex *xp = COMPLEX(x), *yp = COMPLEX(y);
int i, ne_strict = NUM_EQ | (SINGLE_NA << 1);
for(i = 0; i < n; i++)
if(neWithNaN(xp[i].r, yp[i].r, ne_strict) ||
neWithNaN(xp[i].i, yp[i].i, ne_strict))
return FALSE;
}
return TRUE;
}
case STRSXP:
{
int i, n = length(x);
if(n != length(y)) return FALSE;
for(i = 0; i < n; i++) {
/* This special-casing for NAs is not needed */
Rboolean na1 = (STRING_ELT(x, i) == NA_STRING),
na2 = (STRING_ELT(y, i) == NA_STRING);
if(na1 ^ na2) return FALSE;
if(na1 && na2) continue;
if (! Seql(STRING_ELT(x, i), STRING_ELT(y, i))) return FALSE;
}
return TRUE;
}
case CHARSXP: /* Probably unreachable, but better safe than sorry... */
{
/* This matches NAs */
return Seql(x, y);
}
case VECSXP:
case EXPRSXP:
{
int i, n = length(x);
if(n != length(y)) return FALSE;
for(i = 0; i < n; i++)
if(!R_compute_identical(VECTOR_ELT(x, i),VECTOR_ELT(y, i), flags))
return FALSE;
return TRUE;
}
case LANGSXP:
case LISTSXP:
{
while (x != R_NilValue) {
if(y == R_NilValue)
return FALSE;
if(!R_compute_identical(CAR(x), CAR(y), flags))
return FALSE;
if(!R_compute_identical(PRINTNAME(TAG(x)), PRINTNAME(TAG(y)), flags))
return FALSE;
x = CDR(x);
y = CDR(y);
}
return(y == R_NilValue);
}
case CLOSXP:
return(R_compute_identical(FORMALS(x), FORMALS(y), flags) &&
R_compute_identical(BODY_EXPR(x), BODY_EXPR(y), flags) &&
(CLOENV(x) == CLOENV(y) ? TRUE : FALSE) &&
(IGNORE_BYTECODE || R_compute_identical(BODY(x), BODY(y), flags))
);
case SPECIALSXP:
case BUILTINSXP:
return(PRIMOFFSET(x) == PRIMOFFSET(y) ? TRUE : FALSE);
case ENVSXP:
case SYMSXP:
case WEAKREFSXP:
case BCODESXP: /**** is this the best approach? */
return(x == y ? TRUE : FALSE);
case EXTPTRSXP:
return (EXTPTR_PTR(x) == EXTPTR_PTR(y) ? TRUE : FALSE);
case RAWSXP:
if (length(x) != length(y)) return FALSE;
/* Use memcmp (which is ISO C90) to speed up the comparison */
return memcmp((void *)RAW(x), (void *)RAW(y),
length(x) * sizeof(Rbyte)) == 0 ? TRUE : FALSE;
/* case PROMSXP: args are evaluated, so will not be seen */
/* test for equality of the substituted expression -- or should
we require both expression and environment to be identical? */
/*#define PREXPR(x) ((x)->u.promsxp.expr)
#define PRENV(x) ((x)->u.promsxp.env)
return(R_compute_identical(subsititute(PREXPR(x), PRENV(x),
flags),
subsititute(PREXPR(y), PRENV(y))));*/
case S4SXP:
/* attributes already tested, so all slots identical */
return TRUE;
default:
/* these are all supposed to be types that represent constant
entities, so no further testing required ?? */
printf("Unknown Type: %s (%x)\n", type2char(TYPEOF(x)), TYPEOF(x));
return TRUE;
}
}
void rph_cm_free(SEXP cmP) {
CategoryMap *cm = (CategoryMap*)EXTPTR_PTR(cmP);
phast_unregister_protected(cm);
cm_free(cm);
}
/** get value of a field of an object or class
object (int), return signature (string), field name (string)
arrays and objects are returned as IDs (hence not evaluated)
class name can be in either form / or .
*/
REPC SEXP RgetField(SEXP obj, SEXP sig, SEXP name, SEXP trueclass) {
jobject o = 0;
SEXP e;
const char *retsig, *fnam;
char *clnam = 0, *detsig = 0;
jfieldID fid;
jclass cls;
int tc = asInteger(trueclass);
JNIEnv *env=getJNIEnv();
if (obj == R_NilValue) return R_NilValue;
if ( IS_JOBJREF(obj) )
obj = GET_SLOT(obj, install("jobj"));
if (TYPEOF(obj)==EXTPTRSXP) {
jverify(obj);
o=(jobject)EXTPTR_PTR(obj);
} else if (TYPEOF(obj)==STRSXP && LENGTH(obj)==1)
clnam = strdup(CHAR(STRING_ELT(obj, 0)));
else
error("invalid object parameter");
if (!o && !clnam)
error("cannot access a field of a NULL object");
#ifdef RJ_DEBUG
if (o) {
rjprintf("RgetField.object: "); printObject(env, o);
} else {
rjprintf("RgetField.class: %s\n", clnam);
}
#endif
if (o)
cls = objectClass(env, o);
else {
char *c = clnam;
while(*c) { if (*c=='/') *c='.'; c++; }
cls = findClass(env, clnam);
free(clnam);
if (!cls) {
error("cannot find class %s", CHAR(STRING_ELT(obj, 0)));
}
}
if (!cls)
error("cannot determine object class");
#ifdef RJ_DEBUG
rjprintf("RgetField.class: "); printObject(env, cls);
#endif
if (TYPEOF(name)!=STRSXP || LENGTH(name)!=1) {
releaseObject(env, cls);
error("invalid field name");
}
fnam = CHAR(STRING_ELT(name,0));
if (sig == R_NilValue) {
retsig = detsig = findFieldSignature(env, cls, fnam);
if (!retsig) {
releaseObject(env, cls);
error("unable to detect signature for field '%s'", fnam);
}
} else {
if (TYPEOF(sig)!=STRSXP || LENGTH(sig)!=1) {
releaseObject(env, cls);
error("invalid signature parameter");
}
retsig = CHAR(STRING_ELT(sig,0));
}
_dbg(rjprintf("field %s signature is %s\n",fnam,retsig));
if (o) { /* first try non-static fields */
fid = (*env)->GetFieldID(env, cls, fnam, retsig);
checkExceptionsX(env, 1);
if (!fid) { /* if that fails, try static ones */
o = 0;
fid = (*env)->GetStaticFieldID(env, cls, fnam, retsig);
}
} else /* no choice if the object was a string */
fid = (*env)->GetStaticFieldID(env, cls, fnam, retsig);
if (!fid) {
checkExceptionsX(env, 1);
releaseObject(env, cls);
if (detsig) free(detsig);
error("RgetField: field %s not found", fnam);
}
switch (*retsig) {
case 'I': {
int r=o?
(*env)->GetIntField(env, o, fid):
(*env)->GetStaticIntField(env, cls, fid);
e = allocVector(INTSXP, 1);
INTEGER(e)[0] = r;
releaseObject(env, cls);
if (detsig) free(detsig);
return e;
}
case 'S': {
jshort r=o?
(*env)->GetShortField(env, o, fid):
(*env)->GetStaticShortField(env, cls, fid);
e = allocVector(INTSXP, 1);
INTEGER(e)[0] = r;
releaseObject(env, cls);
if (detsig) free(detsig);
return e;
}
case 'C': {
int r=(int) (o?
(*env)->GetCharField(env, o, fid):
(*env)->GetStaticCharField(env, cls, fid));
e = allocVector(INTSXP, 1);
INTEGER(e)[0] = r;
releaseObject(env, cls);
if (detsig) free(detsig);
return e;
}
case 'B': {
int r=(int) (o?
(*env)->GetByteField(env, o, fid):
(*env)->GetStaticByteField(env, cls, fid));
e = allocVector(INTSXP, 1);
INTEGER(e)[0] = r;
releaseObject(env, cls);
if (detsig) free(detsig);
return e;
}
case 'J': {
jlong r=o?
(*env)->GetLongField(env, o, fid):
(*env)->GetStaticLongField(env, cls, fid);
e = allocVector(REALSXP, 1);
REAL(e)[0] = (double)r;
releaseObject(env, cls);
if (detsig) free(detsig);
return e;
}
case 'Z': {
jboolean r=o?
(*env)->GetBooleanField(env, o, fid):
(*env)->GetStaticBooleanField(env, cls, fid);
e = allocVector(LGLSXP, 1);
LOGICAL(e)[0] = r?1:0;
releaseObject(env, cls);
if (detsig) free(detsig);
return e;
}
case 'D': {
double r=o?
(*env)->GetDoubleField(env, o, fid):
(*env)->GetStaticDoubleField(env, cls, fid);
e = allocVector(REALSXP, 1);
REAL(e)[0] = r;
releaseObject(env, cls);
if (detsig) free(detsig);
return e;
}
case 'F': {
double r = (double) (o?
(*env)->GetFloatField(env, o, fid):
(*env)->GetStaticFloatField(env, cls, fid));
e = allocVector(REALSXP, 1);
REAL(e)[0] = r;
releaseObject(env, cls);
if (detsig) free(detsig);
return e;
}
case 'L':
case '[': {
SEXP rv;
jobject r = o?
(*env)->GetObjectField(env, o, fid):
(*env)->GetStaticObjectField(env, cls, fid);
_mp(MEM_PROF_OUT(" %08x LNEW field value\n", (int) r))
releaseObject(env, cls);
if (tc) {
if (detsig) free(detsig);
return new_jobjRef(env, r, 0);
}
if (*retsig=='L') { /* need to fix the class name */
char *d = strdup(retsig), *c = d;
while (*c) { if (*c==';') { *c=0; break; }; c++; }
rv = new_jobjRef(env, r, d+1);
free(d);
} else
rv = new_jobjRef(env, r, retsig);
if (detsig) free(detsig);
return rv;
}
} /* switch */
releaseObject(env, cls);
if (detsig) {
free(detsig);
error("unknown field signature");
}
error("unknown field signature '%s'", retsig);
return R_NilValue;
}
REPC SEXP RsetField(SEXP ref, SEXP name, SEXP value) {
jobject o = 0, otr;
SEXP obj = ref;
const char *fnam;
sig_buffer_t sig;
char *clnam = 0;
jfieldID fid;
jclass cls;
jvalue jval;
JNIEnv *env=getJNIEnv();
if (TYPEOF(name)!=STRSXP && LENGTH(name)!=1)
error("invalid field name");
fnam = CHAR(STRING_ELT(name, 0));
if (obj == R_NilValue) error("cannot set a field of a NULL object");
if (IS_JOBJREF(obj))
obj = GET_SLOT(obj, install("jobj"));
if (TYPEOF(obj)==EXTPTRSXP) {
jverify(obj);
o=(jobject)EXTPTR_PTR(obj);
} else if (TYPEOF(obj)==STRSXP && LENGTH(obj)==1)
clnam = strdup(CHAR(STRING_ELT(obj, 0)));
else
error("invalid object parameter");
if (!o && !clnam)
error("cannot set a field of a NULL object");
#ifdef RJ_DEBUG
if (o) {
rjprintf("RsetField.object: "); printObject(env, o);
} else {
rjprintf("RsetField.class: %s\n", clnam);
}
#endif
if (o)
cls = objectClass(env, o);
else {
char *c = clnam;
while(*c) { if (*c=='/') *c='.'; c++; }
cls = findClass(env, clnam);
if (!cls) {
error("cannot find class %s", CHAR(STRING_ELT(obj, 0)));
}
}
if (!cls)
error("cannot determine object class");
#ifdef RJ_DEBUG
rjprintf("RsetField.class: "); printObject(env, cls);
#endif
init_sigbuf(&sig);
jval = R1par2jvalue(env, value, &sig, &otr);
if (o) {
fid = (*env)->GetFieldID(env, cls, fnam, sig.sig);
if (!fid) {
checkExceptionsX(env, 1);
o = 0;
fid = (*env)->GetStaticFieldID(env, cls, fnam, sig.sig);
}
} else
fid = (*env)->GetStaticFieldID(env, cls, fnam, sig.sig);
if (!fid) {
checkExceptionsX(env, 1);
releaseObject(env, cls);
if (otr) releaseObject(env, otr);
done_sigbuf(&sig);
error("cannot find field %s with signature %s", fnam, sig.sigbuf);
}
switch(sig.sig[0]) {
case 'Z':
o?(*env)->SetBooleanField(env, o, fid, jval.z):
(*env)->SetStaticBooleanField(env, cls, fid, jval.z);
break;
case 'C':
o?(*env)->SetCharField(env, o, fid, jval.c):
(*env)->SetStaticCharField(env, cls, fid, jval.c);
break;
case 'B':
o?(*env)->SetByteField(env, o, fid, jval.b):
(*env)->SetStaticByteField(env, cls, fid, jval.b);
break;
case 'I':
o?(*env)->SetIntField(env, o, fid, jval.i):
(*env)->SetStaticIntField(env, cls, fid, jval.i);
break;
case 'D':
o?(*env)->SetDoubleField(env, o, fid, jval.d):
(*env)->SetStaticDoubleField(env, cls, fid, jval.d);
break;
case 'F':
o?(*env)->SetFloatField(env, o, fid, jval.f):
(*env)->SetStaticFloatField(env, cls, fid, jval.f);
break;
case 'J':
o?(*env)->SetLongField(env, o, fid, jval.j):
(*env)->SetStaticLongField(env, cls, fid, jval.j);
break;
case 'S':
o?(*env)->SetShortField(env, o, fid, jval.s):
(*env)->SetStaticShortField(env, cls, fid, jval.s);
break;
case '[':
case 'L':
o?(*env)->SetObjectField(env, o, fid, jval.l):
(*env)->SetStaticObjectField(env, cls, fid, jval.l);
break;
default:
releaseObject(env, cls);
if (otr) releaseObject(env, otr);
done_sigbuf(&sig);
error("unknown field sighanture %s", sig.sigbuf);
}
done_sigbuf(&sig);
releaseObject(env, cls);
if (otr) releaseObject(env, otr);
return ref;
}
SEXP cr_set(SEXP sc, SEXP keys, SEXP values) {
rconn_t *c;
int n, i;
const char **argv = argbuf;
size_t *argsz = argszbuf;
redisReply *reply;
if (!Rf_inherits(sc, "redisConnection")) Rf_error("invalid connection");
c = (rconn_t*) EXTPTR_PTR(sc);
if (!c) Rf_error("invalid connection (NULL)");
rc_validate_connection(c, 0);
if (TYPEOF(keys) != STRSXP)
Rf_error("invalid keys");
n = LENGTH(keys);
if (n < 1) return R_NilValue;
/* FIXME: we check only the first ... in the hope that we support more formats later */
if (TYPEOF(values) != VECSXP || TYPEOF(VECTOR_ELT(values, 0)) != RAWSXP)
Rf_error ("Sorry, values can only be a list of raw vectors for now");
if (LENGTH(values) != n) Rf_error("keys/values length mismatch");
if (2 * n + 1 > NARGBUF) {
argv = malloc(sizeof(const char*) * (2 * n + 2));
if (!argv)
Rf_error("out of memory");
argsz = malloc(sizeof(size_t) * (2 * n + 2));
if (!argsz) {
free(argv);
Rf_error("out of memory");
}
}
argv[0] = "MSET"; argsz[0] = strlen(argv[0]);
for (i = 0; i < n; i++) {
argv [2 * i + 1] = CHAR(STRING_ELT(keys, i));
argsz[2 * i + 1] = strlen(argv[2 * i + 1]);
argv [2 * i + 2] = (char*) RAW(VECTOR_ELT(values, i));
argsz[2 * i + 2] = LENGTH(VECTOR_ELT(values, i));
}
reply = redisCommandArgv(c->rc, 2 * n + 1, argv, argsz);
if (!reply && (c->flags & RCF_RETRY)) {
SEXP es = Rf_mkChar(c->rc->errstr);
rc_close(c);
rc_validate_connection(c, 1);
if (c->rc)
reply = redisCommandArgv(c->rc, 2 * n + 1, argv, argsz);
else {
if (argv != argbuf) {
free(argv);
free(argsz);
}
Rf_error("MGET error: %s and re-connect failed", CHAR(es));
}
}
if (argv != argbuf) {
free(argv);
free(argsz);
}
if (!reply) {
SEXP es = Rf_mkChar(c->rc->errstr);
rc_close(c);
Rf_error("MSET error: %s", CHAR(es));
}
/* Rprintf("reply, type=%d\n", reply->type); */
/* Note: the result is normally "status" - probably nothing useful we can do with that? */
freeReplyObject(reply);
return R_NilValue;
}
SEXP cr_get(SEXP sc, SEXP keys, SEXP asList) {
rconn_t *c;
int n, i, use_list = Rf_asInteger(asList);
const char **argv = argbuf;
redisReply *reply;
SEXP res;
if (!Rf_inherits(sc, "redisConnection")) Rf_error("invalid connection");
c = (rconn_t*) EXTPTR_PTR(sc);
if (!c) Rf_error("invalid connection (NULL)");
rc_validate_connection(c, 0);
if (TYPEOF(keys) != STRSXP)
Rf_error("invalid keys");
n = LENGTH(keys);
if (use_list < 0) /* asList == NA -> list for non scalar results only */
use_list = (n == 1) ? 0 : 1;
if (n != 1 && !use_list) Rf_error("exaclty one key must be specified with list=FALSE");
if (n + 1 > NARGBUF) {
argv = malloc(sizeof(const char*) * (n + 2));
if (!argv)
Rf_error("out of memory");
}
argv[0] = "MGET";
for (i = 0; i < n; i++)
argv[i + 1] = CHAR(STRING_ELT(keys, i));
/* we use strings only, so no need to supply argvlen */
reply = redisCommandArgv(c->rc, n + 1, argv, 0);
if (!reply && (c->flags & RCF_RETRY)) {
SEXP es = Rf_mkChar(c->rc->errstr);
rc_close(c);
rc_validate_connection(c, 1);
if (c->rc)
reply = redisCommandArgv(c->rc, n + 1, argv, 0);
else {
if (argv != argbuf)
free(argv);
Rf_error("MGET error: %s and re-connect failed", CHAR(es));
}
}
if (argv != argbuf)
free(argv);
if (!reply) {
SEXP es = Rf_mkChar(c->rc->errstr);
rc_close(c);
Rf_error("MGET error: %s", CHAR(es));
}
/* Rprintf("reply, type=%d\n", reply->type); */
if (reply->type != REDIS_REPLY_ARRAY) {
freeReplyObject(reply);
Rf_error("unexpected result type");
}
if (reply->elements != n) {
freeReplyObject(reply);
Rf_error("unexpected result length - should be %d but is %d", n, (int) reply->elements);
}
if (use_list) {
int n = reply->elements;
res = PROTECT(Rf_allocVector(VECSXP, n));
Rf_setAttrib(res, R_NamesSymbol, keys);
for (i = 0; i < n; i++)
SET_VECTOR_ELT(res, i, rc_reply2R(reply->element[i]));
UNPROTECT(1);
} else
res = rc_reply2R(reply->element[0]);
freeReplyObject(reply);
return res;
}
static void rsconn_fin(SEXP what) {
rsconn_t *c = (rsconn_t*) EXTPTR_PTR(what);
if (c) rsc_close(c);
}
