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