Beispiel #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);
}
Beispiel #2
0
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);
}