/*
The real invoke mechanism that handles all the details.
*/
SEXP
R_COM_Invoke(SEXP obj, SEXP methodName, SEXP args, WORD callType, WORD doReturn,
SEXP ids)
{
IDispatch* disp;
SEXP ans = R_NilValue;
int numNamedArgs = 0, *namedArgPositions = NULL, i;
HRESULT hr;
// callGC();
disp = (IDispatch *) getRDCOMReference(obj);
#ifdef ANNOUNCE_COM_CALLS
fprintf(stderr, "<COM> %s %d %p\n", CHAR(STRING_ELT(methodName, 0)), (int) callType,
disp);fflush(stderr);
#endif
DISPID *methodIds;
const char *pmname = CHAR(STRING_ELT(methodName, 0));
BSTR *comNames = NULL;
SEXP names = GET_NAMES(args);
int numNames = Rf_length(names) + 1;
SetErrorInfo(0L, NULL);
methodIds = (DISPID *) S_alloc(numNames, sizeof(DISPID));
namedArgPositions = (int*) S_alloc(numNames, sizeof(int)); // we may not use all of these, but we allocate them
if(Rf_length(ids) == 0) {
comNames = (BSTR*) S_alloc(numNames, sizeof(BSTR));
comNames[0] = AsBstr(pmname);
for(i = 0; i < Rf_length(names); i++) {
const char *str = CHAR(STRING_ELT(names, i));
if(str && str[0]) {
comNames[numNamedArgs+1] = AsBstr(str);
namedArgPositions[numNamedArgs] = i;
numNamedArgs++;
}
}
numNames = numNamedArgs + 1;
hr = disp->GetIDsOfNames(IID_NULL, comNames, numNames, LOCALE_USER_DEFAULT, methodIds);
if(FAILED(hr) || hr == DISP_E_UNKNOWNNAME /* || DISPID mid == DISPID_UNKNOWN */) {
PROBLEM "Cannot locate %d name(s) %s in COM object (status = %d)", numNamedArgs, pmname, (int) hr
ERROR;
}
} else {
for(i = 0; i < Rf_length(ids); i++) {
methodIds[i] = (MEMBERID) NUMERIC_DATA(ids)[i];
//XXX What about namedArgPositions here.
}
}
DISPPARAMS params = {NULL, NULL, 0, 0};
if(args != NULL && Rf_length(args) > 0) {
hr = R_getCOMArgs(args, ¶ms, methodIds, numNamedArgs, namedArgPositions);
if(FAILED(hr)) {
clearVariants(¶ms);
freeSysStrings(comNames, numNames);
PROBLEM "Failed in converting arguments to DCOM call"
ERROR;
}
if(callType & DISPATCH_PROPERTYPUT) {
params.rgdispidNamedArgs = (DISPID*) S_alloc(1, sizeof(DISPID));
params.rgdispidNamedArgs[0] = DISPID_PROPERTYPUT;
params.cNamedArgs = 1;
}
}
VARIANT varResult, *res = NULL;
if(doReturn && callType != DISPATCH_PROPERTYPUT)
VariantInit(res = &varResult);
EXCEPINFO exceptionInfo;
memset(&exceptionInfo, 0, sizeof(exceptionInfo));
unsigned int nargErr = 100;
#ifdef RDCOM_VERBOSE
if(params.cNamedArgs) {
errorLog("# of named arguments to %d: %d\n", (int) methodIds[0],
(int) params.cNamedArgs);
for(int p = params.cNamedArgs; p > 0; p--)
errorLog("%d) id %d, type %d\n", p,
(int) params.rgdispidNamedArgs[p-1],
(int) V_VT(&(params.rgvarg[p-1])));
}
#endif
hr = disp->Invoke(methodIds[0], IID_NULL, LOCALE_USER_DEFAULT, callType, ¶ms, res, &exceptionInfo, &nargErr);
if(FAILED(hr)) {
if(hr == DISP_E_MEMBERNOTFOUND) {
errorLog("Error because member not found %d\n", nargErr);
}
#ifdef RDCOM_VERBOSE
errorLog("Error (%d): <in argument %d>, call type = %d, call = \n",
(int) hr, (int)nargErr, (int) callType, pmname);
#endif
clearVariants(¶ms);
freeSysStrings(comNames, numNames);
if(checkErrorInfo(disp, hr, NULL) != S_OK) {
fprintf(stderr, "checkErrorInfo %d\n", (int) hr);fflush(stderr);
COMError(hr);
}
}
if(res) {
ans = R_convertDCOMObjectToR(&varResult);
VariantClear(&varResult);
}
clearVariants(¶ms);
freeSysStrings(comNames, numNames);
#ifdef ANNOUNCE_COM_CALLS
fprintf(stderr, "</COM>\n", (int) callType);fflush(stderr);
#endif
return(ans);
}
HRESULT
R_getCLSIDFromString(SEXP className, CLSID *classId)
{
HRESULT hr;
const char *ptr;
int status = FALSE;
BSTR str;
ptr = CHAR(STRING_ELT(className, 0));
str = AsBstr(ptr);
hr = CLSIDFromString(str, classId);
if(SUCCEEDED(hr)) {
SysFreeString(str);
return(S_OK);
}
status = CLSIDFromProgID(str, classId);
SysFreeString(str);
return status;
}
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);
}
SEXP
R_create2DArray(SEXP obj)
{
SAFEARRAYBOUND bounds[2] = {{0, 0}, {0, 0}};;
SAFEARRAY *arr;
void *data, *el;
VARTYPE type = VT_R8;
SEXP dim = GET_DIM(obj);
int integer;
double real;
BSTR bstr;
bounds[0].cElements = INTEGER(dim)[0];
bounds[1].cElements = INTEGER(dim)[1];
type = getDCOMType(obj);
arr = SafeArrayCreate(type, 2, bounds);
SafeArrayAccessData(arr, (void**) &data);
long indices[2];
UINT i, j, ctr = 0;
for(j = 0 ; j < bounds[1].cElements; j++) {
indices[1] = j;
for(i = 0; i < bounds[0].cElements; i++, ctr++) {
indices[0] = i;
switch(TYPEOF(obj)) {
case LGLSXP:
integer = (LOGICAL(obj)[ctr] ? 1:0);
el = &integer;
break;
case REALSXP:
real = REAL(obj)[ctr];
el = ℜ
break;
case INTSXP:
integer = INTEGER(obj)[ctr];
el = &integer;
break;
case STRSXP:
bstr = AsBstr(CHAR(STRING_ELT(obj, ctr)));
el = (void*) bstr;
break;
default:
continue;
break;
}
SafeArrayPutElement(arr, indices, el);
}
}
SafeArrayUnaccessData(arr);
VARIANT *var;
var = (VARIANT*) malloc(sizeof(VARIANT));
VariantInit(var);
V_VT(var) = VT_ARRAY | type;
V_ARRAY(var) = arr;
SEXP ans;
PROTECT(ans = R_MakeExternalPtr((void*) var, Rf_install("R_VARIANT"), R_NilValue));
R_RegisterCFinalizer(ans, RDCOM_SafeArray_finalizer);
UNPROTECT(1);
return(ans);
}
SAFEARRAY*
createRDCOMArray(SEXP obj, VARIANT *var)
{
VARTYPE type;
unsigned int cDims = 1, len;
SAFEARRAYBOUND bounds[1];
SAFEARRAY *arr;
void *data;
len = Rf_length(obj);
bounds[0].lLbound = 0;
bounds[0].cElements = len;
type = getDCOMType(obj);
arr = SafeArrayCreate(type, cDims, bounds);
HRESULT hr = SafeArrayAccessData(arr, (void**) &data);
if(hr != S_OK) {
//std::cerr <<"Problems accessing data" << std::endl;
REprintf("Problems accessing data\n");
SafeArrayDestroy(arr);
return(NULL);
}
switch(TYPEOF(obj)) {
case REALSXP:
memcpy(data, REAL(obj), sizeof(double) * len);
break;
case INTSXP:
memcpy(data, INTEGER(obj), sizeof(LOGICAL(obj)[0]) * len);
break;
case LGLSXP:
for(unsigned int i = 0 ; i < len ; i++)
((bool *) data)[i] = LOGICAL(obj)[i];
break;
case STRSXP:
for(unsigned int i = 0 ; i < len ; i++)
((BSTR *) data)[i] = AsBstr(getRString(obj, i));
break;
case VECSXP:
for(unsigned int i = 0 ; i < len ; i++) {
VARIANT *v = &(((VARIANT *) data)[i]);
VariantInit(v);
R_convertRObjectToDCOM(VECTOR_ELT(obj, i), v);
}
break;
default:
//std::cerr <<"Array case not handled yet for R type " << TYPEOF(obj) << std::endl;
REprintf("Array case not handled yet for R type %d\n", TYPEOF(obj));
break;
}
SafeArrayUnaccessData(arr);
if(var) {
V_VT(var) = VT_ARRAY | type;
V_ARRAY(var) = arr;
}
return(arr);
}
