Пример #1
1
/* 
 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, &params, methodIds, numNamedArgs, namedArgPositions);

   if(FAILED(hr)) {
     clearVariants(&params);
     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, &params, 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(&params);
    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(&params);
 freeSysStrings(comNames, numNames);

#ifdef ANNOUNCE_COM_CALLS
 fprintf(stderr, "</COM>\n", (int) callType);fflush(stderr);
#endif

 return(ans);
}
Пример #2
0
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);
}
Пример #3
0
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);
}
Пример #4
0
/* 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);
}