/*
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
R_create(SEXP className)
{
DWORD context = CLSCTX_SERVER;
SEXP ans;
CLSID classId;
IID refId = IID_IDispatch;
IUnknown *unknown, *punknown = NULL;
HRESULT hr = R_getCLSIDFromString(className, &classId);
if(FAILED(hr))
COMError(hr);
SCODE sc = CoCreateInstance(classId, punknown, context, refId, (void **) &unknown);
if(FAILED(sc)) {
TCHAR buf[512];
GetScodeString(sc, buf, sizeof(buf)/sizeof(buf[0]));
PROBLEM "Failed to create COM object: %s", buf
ERROR;
}
//Already AddRef in the CoCreateInstance
// so no need to do it now ( unknown->AddRef())
ans = R_createRCOMUnknownObject((void *) unknown, "COMIDispatch");
return(ans);
}
SEXP
R_getCLSIDFromName(SEXP className)
{
CLSID classId;
HRESULT hr;
SEXP ans;
hr = R_getCLSIDFromString(className, &classId);
if(!SUCCEEDED(hr)) {
COMError(hr);
}
LPOLESTR str;
hr = StringFromCLSID(classId, &str);
if(!SUCCEEDED(hr))
COMError(hr);
//???
ans = mkString(FromBstr(str));
CoTaskMemFree(str);
return(ans);
}
/* Determines whether we can use the error information from the
source object and if so, throws that as an error.
If serr is non-NULL, then the error is not thrown in R
but a COMSErrorInfo object is returned with the information in it.
*/
HRESULT
checkErrorInfo(IUnknown *obj, HRESULT status, SEXP *serr)
{
HRESULT hr;
ISupportErrorInfo *info;
fprintf(stderr, "<checkErrorInfo> %X \n", (unsigned int) status);
if(serr)
*serr = NULL;
hr = obj->QueryInterface(IID_ISupportErrorInfo, (void **)&info);
if(hr != S_OK) {
fprintf(stderr, "No support for ISupportErrorInfo\n");fflush(stderr);
return(hr);
}
info->AddRef();
hr = info->InterfaceSupportsErrorInfo(IID_IDispatch);
info->Release();
if(hr != S_OK) {
fprintf(stderr, "No support for InterfaceSupportsErrorInfo\n");fflush(stderr);
return(hr);
}
IErrorInfo *errorInfo;
hr = GetErrorInfo(0L, &errorInfo);
if(hr != S_OK) {
/* fprintf(stderr, "GetErrorInfo failed\n");fflush(stderr); */
COMError(status);
return(hr);
}
/* So there is some information for us. Use it. */
SEXP klass, ans, tmp;
BSTR ostr;
char *str;
errorInfo->AddRef();
if(serr) {
PROTECT(klass = MAKE_CLASS("SCOMErrorInfo"));
PROTECT(ans = NEW(klass));
PROTECT(tmp = NEW_CHARACTER(1));
errorInfo->GetSource(&ostr);
SET_STRING_ELT(tmp, 0, COPY_TO_USER_STRING(FromBstr(ostr)));
SET_SLOT(ans, Rf_install("source"), tmp);
UNPROTECT(1);
PROTECT(tmp = NEW_CHARACTER(1));
errorInfo->GetDescription(&ostr);
SET_STRING_ELT(tmp, 0, COPY_TO_USER_STRING(str = FromBstr(ostr)));
SET_SLOT(ans, Rf_install("description"), tmp);
UNPROTECT(1);
PROTECT(tmp = NEW_NUMERIC(1));
NUMERIC_DATA(tmp)[0] = status;
SET_SLOT(ans, Rf_install("status"), tmp);
*serr = ans;
UNPROTECT(3);
errorInfo->Release();
PROBLEM "%s", str
WARN;
} else {
errorInfo->GetDescription(&ostr);
str = FromBstr(ostr);
errorInfo->GetSource(&ostr);
errorInfo->Release();
PROBLEM "%s (%s)", str, FromBstr(ostr)
ERROR;
}
return(hr);
}
