/* 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); }
SEXP getArray(SAFEARRAY *arr, int dimNo, int numDims, long *indices) { long lb, ub, n, i; HRESULT status; SEXP ans; int rtype = -1; status = SafeArrayGetLBound(arr, dimNo, &lb); if(FAILED(status)) { TCHAR buf[512]; GetScodeString(status, buf, sizeof(buf)/sizeof(buf[0])); PROBLEM "Can't get lower bound of array: %s", buf ERROR; } status = SafeArrayGetUBound(arr, dimNo, &ub); if(FAILED(status)) { TCHAR buf[512]; GetScodeString(status, buf, sizeof(buf)/sizeof(buf[0])); PROBLEM "Can't get upper bound of array: %s", buf ERROR; } n = ub-lb+1; PROTECT(ans = NEW_LIST(n)); for(i = 0; i < n; i++) { SEXP el; indices[dimNo - 1] = lb + i; if(dimNo == 1) { VARIANT variant; VariantInit(&variant); status = SafeArrayGetElement(arr, indices, &variant); if(FAILED(status)) { TCHAR buf[512]; GetScodeString(status, buf, sizeof(buf)/sizeof(buf[0])); PROBLEM "Can't get element %d of array %s", (int) indices[dimNo-1], buf ERROR; } el = R_convertDCOMObjectToR(&variant); } else { el = getArray(arr, dimNo - 1, numDims, indices); } if(i == 0) rtype = TYPEOF(el); else if(rtype != -1 ){ if(TYPEOF(el) != rtype) rtype = -1; } SET_VECTOR_ELT(ans, i, el); } if(numDims == 1 && rtype != -1) { switch(rtype) { case INTSXP: case LGLSXP: case REALSXP: case STRSXP: ans = UnList(ans); break; } } UNPROTECT(1); return(ans); }