HIDE void deserializeSEXP(SEXP o) {
_dbg(rjprintf("attempt to deserialize %p (clCL=%p, oCL=%p)\n", o, clClassLoader, oClassLoader));
SEXP s = EXTPTR_PROT(o);
if (TYPEOF(s) == RAWSXP && EXTPTR_PTR(o) == NULL) {
JNIEnv *env = getJNIEnv();
if (env && clClassLoader && oClassLoader) {
jbyteArray ser = newByteArray(env, RAW(s), LENGTH(s));
if (ser) {
jmethodID mid = (*env)->GetMethodID(env, clClassLoader, "toObject", "([B)Ljava/lang/Object;");
if (mid) {
jobject res = (*env)->CallObjectMethod(env, oClassLoader, mid, ser);
if (res) {
jobject go = makeGlobal(env, res);
_mp(MEM_PROF_OUT("R %08x RNEW %08x\n", (int) go, (int) res))
if (go) {
_dbg(rjprintf(" - succeeded: %p\n", go));
/* set the deserialized object */
EXTPTR_PTR(o) = (SEXP) go;
/* Note: currently we don't remove the serialized content, because it was created explicitly using .jcache to allow repeated saving. Once this is handled by a hook, we shall remove it. However, to assure compatibility TAG is always NULL for now, so we do clear the cache if TAG is non-null for future use. */
if (EXTPTR_TAG(o) != R_NilValue) {
/* remove the serialized raw vector */
SETCDR(o, R_NilValue); /* Note: this is abuse of the API since it uses the fact that PROT is stored in CDR */
}
}
}
}
releaseObject(env, ser);
}
}
static VARIANT *
R_getVariantRef(SEXP ref)
{
VARIANT *p;
if(TYPEOF(ref) != EXTPTRSXP) {
PROBLEM "Argument to R_getVariantRef must be an external pointer"
ERROR;
}
if(EXTPTR_TAG(ref) != Rf_install("VARIANTReference")) {
PROBLEM "Argument to R_getVariantRef does not have the correct tag."
ERROR;
}
p = (VARIANT *) R_ExternalPtrAddr(ref);
return(p);
}
HRESULT
R_convertRObjectToDCOM(SEXP obj, VARIANT *var)
{
HRESULT status;
int type = R_typeof(obj);
if(!var)
return(S_FALSE);
#ifdef RDCOM_VERBOSE
errorLog("Type of argument %d\n", type);
#endif
if(type == EXTPTRSXP && EXTPTR_TAG(obj) == Rf_install("R_VARIANT")) {
VARIANT *tmp;
tmp = (VARIANT *) R_ExternalPtrAddr(obj);
if(tmp) {
//XXX
VariantCopy(var, tmp);
return(S_OK);
}
}
if(ISCOMIDispatch(obj)) {
IDispatch *ptr;
ptr = (IDispatch *) derefRIDispatch(obj);
V_VT(var) = VT_DISPATCH;
V_DISPATCH(var) = ptr;
//XX
ptr->AddRef();
return(S_OK);
}
if(ISSInstanceOf(obj, "COMDate")) {
double val;
val = NUMERIC_DATA(GET_SLOT(obj, Rf_install(".Data")))[0];
V_VT(var) = VT_DATE;
V_DATE(var) = val;
return(S_OK);
} else if(ISSInstanceOf(obj, "COMCurrency")) {
double val;
val = NUMERIC_DATA(GET_SLOT(obj, Rf_install(".Data")))[0];
V_VT(var) = VT_R8;
V_R8(var) = val;
VariantChangeType(var, var, 0, VT_CY);
return(S_OK);
} else if(ISSInstanceOf(obj, "COMDecimal")) {
double val;
val = NUMERIC_DATA(GET_SLOT(obj, Rf_install(".Data")))[0];
V_VT(var) = VT_R8;
V_R8(var) = val;
VariantChangeType(var, var, 0, VT_DECIMAL);
return(S_OK);
}
/* We have a complex object and we are not going to try to convert it directly
but instead create an COM server object to represent it to the outside world. */
if((type == VECSXP && Rf_length(GET_NAMES(obj))) || Rf_length(GET_CLASS(obj)) > 0 || isMatrix(obj)) {
status = createGenericCOMObject(obj, var);
if(status == S_OK)
return(S_OK);
}
if(Rf_length(obj) == 0) {
V_VT(var) = VT_VOID;
return(S_OK);
}
if(type == VECSXP || Rf_length(obj) > 1) {
createRDCOMArray(obj, var);
return(S_OK);
}
switch(type) {
case STRSXP:
V_VT(var) = VT_BSTR;
V_BSTR(var) = AsBstr(getRString(obj, 0));
break;
case INTSXP:
V_VT(var) = VT_I4;
V_I4(var) = R_integerScalarValue(obj, 0);
break;
case REALSXP:
V_VT(var) = VT_R8;
V_R8(var) = R_realScalarValue(obj, 0);
break;
case LGLSXP:
V_VT(var) = VT_BOOL;
V_BOOL(var) = R_logicalScalarValue(obj, 0) ? VARIANT_TRUE : VARIANT_FALSE;
break;
case VECSXP:
break;
}
return(S_OK);
}
static R_size_t objectsize(SEXP s)
{
R_size_t cnt = 0, vcnt = 0;
SEXP tmp, dup;
Rboolean isVec = FALSE;
switch (TYPEOF(s)) {
case NILSXP:
return(0);
break;
case SYMSXP:
break;
case LISTSXP:
case LANGSXP:
case BCODESXP:
case DOTSXP:
cnt += objectsize(TAG(s));
cnt += objectsize(CAR(s));
cnt += objectsize(CDR(s));
break;
case CLOSXP:
cnt += objectsize(FORMALS(s));
cnt += objectsize(BODY(s));
/* no charge for the environment */
break;
case ENVSXP:
R_CheckStack(); /* in case attributes might lead to a cycle */
case PROMSXP:
case SPECIALSXP:
case BUILTINSXP:
break;
case CHARSXP:
vcnt = BYTE2VEC(length(s)+1);
isVec = TRUE;
break;
case LGLSXP:
case INTSXP:
vcnt = INT2VEC(xlength(s));
isVec = TRUE;
break;
case REALSXP:
vcnt = FLOAT2VEC(xlength(s));
isVec = TRUE;
break;
case CPLXSXP:
vcnt = COMPLEX2VEC(xlength(s));
isVec = TRUE;
break;
case STRSXP:
vcnt = PTR2VEC(xlength(s));
PROTECT(dup = Rf_csduplicated(s));
for (R_xlen_t i = 0; i < xlength(s); i++) {
tmp = STRING_ELT(s, i);
if(tmp != NA_STRING && !LOGICAL(dup)[i])
cnt += objectsize(tmp);
}
isVec = TRUE;
UNPROTECT(1);
break;
case ANYSXP:
/* we don't know about these */
break;
case VECSXP:
case EXPRSXP:
case WEAKREFSXP:
/* Generic Vector Objects */
vcnt = PTR2VEC(xlength(s));
for (R_xlen_t i = 0; i < xlength(s); i++)
cnt += objectsize(VECTOR_ELT(s, i));
isVec = TRUE;
break;
case EXTPTRSXP:
cnt += sizeof(void *); /* the actual pointer */
cnt += objectsize(EXTPTR_PROT(s));
cnt += objectsize(EXTPTR_TAG(s));
break;
case RAWSXP:
vcnt = BYTE2VEC(xlength(s));
isVec = TRUE;
break;
case S4SXP:
/* Has TAG and ATRIB but no CAR nor CDR */
cnt += objectsize(TAG(s));
break;
default:
UNIMPLEMENTED_TYPE("object.size", s);
}
/* add in node space:
we need to take into account the rounding up that goes on
in the node classes. */
if(isVec) {
cnt += sizeof(SEXPREC_ALIGN);
if (vcnt > 16) cnt += 8*vcnt;
else if (vcnt > 8) cnt += 128;
else if (vcnt > 6) cnt += 64;
else if (vcnt > 4) cnt += 48;
else if (vcnt > 2) cnt += 32;
else if (vcnt > 1) cnt += 16;
else if (vcnt > 0) cnt += 8;
} else cnt += sizeof(SEXPREC);
/* add in attributes: these are fake for CHARSXPs */
if(TYPEOF(s) != CHARSXP) cnt += objectsize(ATTRIB(s));
return(cnt);
}
