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);
}
SEXP
R_convertDCOMObjectToR(VARIANT *var)
{
SEXP ans = R_NilValue;
VARTYPE type = V_VT(var);
#if defined(RDCOM_VERBOSE) && RDCOM_VERBOSE
errorLog("Converting VARIANT to R %d\n", V_VT(var));
#endif
if(V_ISARRAY(var)) {
#if defined(RDCOM_VERBOSE) && RDCOM_VERBOSE
errorLog("Finishing convertDCOMObjectToR - convert array\n");
#endif
return(convertArrayToR(var));
} else if(V_VT(var) == VT_DISPATCH || (V_ISBYREF(var) && ((V_VT(var) & (~ VT_BYREF)) == VT_DISPATCH)) ) {
IDispatch *ptr;
if(V_ISBYREF(var)) {
#if defined(RDCOM_VERBOSE) && RDCOM_VERBOSE
errorLog("BYREF and DISPATCH in convertDCOMObjectToR\n");
#endif
IDispatch **tmp = V_DISPATCHREF(var);
if(!tmp)
return(ans);
ptr = *tmp;
} else
ptr = V_DISPATCH(var);
//xxx
if(ptr)
ptr->AddRef();
ans = R_createRCOMUnknownObject((void*) ptr, "COMIDispatch");
#if defined(RDCOM_VERBOSE) && RDCOM_VERBOSE
errorLog("Finished convertDCOMObjectToR COMIDispatch\n");
#endif
return(ans);
}
if(V_ISBYREF(var)) {
VARTYPE rtype = type & (~ VT_BYREF);
#if defined(RDCOM_VERBOSE) && RDCOM_VERBOSE
errorLog("ISBYREF() in convertDCOMObjectToR: ref type %d\n", rtype);
#endif
if(rtype == VT_BSTR) {
BSTR *tmp;
const char *ptr = "";
#if defined(RDCOM_VERBOSE) && RDCOM_VERBOSE
errorLog("BYREF and BSTR convertDCOMObjectToR (scalar string)\n");
#endif
tmp = V_BSTRREF(var);
if(tmp)
ptr = FromBstr(*tmp);
ans = R_scalarString(ptr);
return(ans);
} else if(rtype == VT_BOOL || rtype == VT_I4 || rtype == VT_R8){
return(createVariantRef(var, rtype));
} else {
fprintf(stderr, "Unhandled by-reference conversion type %d\n", V_VT(var));fflush(stderr);
return(R_NilValue);
}
}
switch(type) {
case VT_BOOL:
ans = R_scalarLogical( (Rboolean) (V_BOOL(var) ? TRUE : FALSE));
break;
case VT_UI1:
case VT_UI2:
case VT_UI4:
case VT_UINT:
VariantChangeType(var, var, 0, VT_I4);
ans = R_scalarReal((double) V_I4(var));
break;
case VT_I1:
case VT_I2:
case VT_I4:
case VT_INT:
VariantChangeType(var, var, 0, VT_I4);
ans = R_scalarInteger(V_I4(var));
break;
case VT_R4:
case VT_R8:
case VT_I8:
VariantChangeType(var, var, 0, VT_R8);
ans = R_scalarReal(V_R8(var));
break;
case VT_CY:
case VT_DATE:
case VT_HRESULT:
case VT_DECIMAL:
VariantChangeType(var, var, 0, VT_R8);
ans = numberFromVariant(var, type);
break;
case VT_BSTR:
{
char *ptr = FromBstr(V_BSTR(var));
ans = R_scalarString(ptr);
}
break;
case VT_UNKNOWN:
{
IUnknown *ptr = V_UNKNOWN(var);
//xxx
if(ptr)
ptr->AddRef();
ans = R_createRCOMUnknownObject((void**) ptr, "COMUnknown");
}
break;
case VT_EMPTY:
case VT_NULL:
case VT_VOID:
return(R_NilValue);
break;
/*XXX Need to fill these in */
case VT_RECORD:
case VT_FILETIME:
case VT_BLOB:
case VT_STREAM:
case VT_STORAGE:
case VT_STREAMED_OBJECT:
/* case LPSTR: */
case VT_LPWSTR:
case VT_PTR:
case VT_ERROR:
case VT_VARIANT:
case VT_CARRAY:
case VT_USERDEFINED:
default:
fprintf(stderr, "Unhandled conversion type %d\n", V_VT(var));fflush(stderr);
//XXX this consumes the variant. So the variant clearance in Invoke() does it again!
ans = createRVariantObject(var, V_VT(var));
}
#if defined(RDCOM_VERBOSE) && RDCOM_VERBOSE
errorLog("Finished convertDCOMObjectToR\n");
#endif
return(ans);
}
