From f9c2d049a08336feebf1858e1e6bc30187cde666 Mon Sep 17 00:00:00 2001 From: Gregory Demin Date: Tue, 2 Nov 2021 19:53:26 +0300 Subject: [PATCH] Commit from Linux - lineendings are changed --- .Rbuildignore | 22 +- .gitignore | 12 +- DESCRIPTION | 66 +- NEWS | 158 ++-- src/COMError.cpp | 1194 +++++++++++++-------------- src/RCOMObject.cpp | 934 +++++++++++----------- src/connect.cpp | 1146 +++++++++++++------------- src/converters.cpp | 1904 ++++++++++++++++++++++---------------------- src/converters.h | 28 +- 9 files changed, 2732 insertions(+), 2732 deletions(-) diff --git a/.Rbuildignore b/.Rbuildignore index 9c39b1f..cd91fd4 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,11 +1,11 @@ -^.*\.Rproj$ -^\.Rproj\.user$ -^tests -\.Rhistory -\.gitignore -\.git -^SupplementaryMaterials$ -cran-comments\.md -README\.md -^doc$ -^Meta$ +^.*\.Rproj$ +^\.Rproj\.user$ +^tests +\.Rhistory +\.gitignore +\.git +^SupplementaryMaterials$ +cran-comments\.md +README\.md +^doc$ +^Meta$ diff --git a/.gitignore b/.gitignore index 8008321..4a3c169 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,6 @@ -.Rproj.user -.Rhistory -.RData -SupplementaryMaterials -/doc/ -/Meta/ +.Rproj.user +.Rhistory +.RData +SupplementaryMaterials +/doc/ +/Meta/ diff --git a/DESCRIPTION b/DESCRIPTION index 0dec788..7b128b1 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,33 +1,33 @@ -Package: excel.link -Type: Package -Title: Convenient Data Exchange with Microsoft Excel -Version: 0.9.10 -Author: Gregory Demin . To comply CRAN policy - includes source code from 'RDCOMClient' (http://www.omegahat.net/RDCOMClient/) by - Duncan Temple Lang . -Maintainer: Gregory Demin -Depends: - methods, - grDevices, - utils -Suggests: - knitr, - rmarkdown -VignetteBuilder: knitr -OS_type: windows -Description: Allows access to data in running instance of Microsoft Excel - (e. g. 'xl[a1] = xl[b2]*3' and so on). Graphics can be transferred with - 'xl[a1] = current.graphics()'. Additionally there are function for reading/writing - 'Excel' files - 'xl.read.file'/'xl.save.file'. They are not fast but able to read/write - '*.xlsb'-files and password-protected files. There is an Excel workbook with - examples of calling R from Excel in the 'doc' folder. It tries to keep things as - simple as possible - there are no needs in any additional - installations besides R, only 'VBA' code in the Excel workbook. - Microsoft Excel is required for this package. -License: GPL (>= 2) -URL: https://github.com/gdemin/excel.link -BugReports: https://github.com/gdemin/excel.link/issues -LazyLoad: yes -ByteCompile: TRUE -NeedsCompilation: yes -RoxygenNote: 7.1.2 +Package: excel.link +Type: Package +Title: Convenient Data Exchange with Microsoft Excel +Version: 0.9.10 +Author: Gregory Demin . To comply CRAN policy + includes source code from 'RDCOMClient' (http://www.omegahat.net/RDCOMClient/) by + Duncan Temple Lang . +Maintainer: Gregory Demin +Depends: + methods, + grDevices, + utils +Suggests: + knitr, + rmarkdown +VignetteBuilder: knitr +OS_type: windows +Description: Allows access to data in running instance of Microsoft Excel + (e. g. 'xl[a1] = xl[b2]*3' and so on). Graphics can be transferred with + 'xl[a1] = current.graphics()'. Additionally there are function for reading/writing + 'Excel' files - 'xl.read.file'/'xl.save.file'. They are not fast but able to read/write + '*.xlsb'-files and password-protected files. There is an Excel workbook with + examples of calling R from Excel in the 'doc' folder. It tries to keep things as + simple as possible - there are no needs in any additional + installations besides R, only 'VBA' code in the Excel workbook. + Microsoft Excel is required for this package. +License: GPL (>= 2) +URL: https://github.com/gdemin/excel.link +BugReports: https://github.com/gdemin/excel.link/issues +LazyLoad: yes +ByteCompile: TRUE +NeedsCompilation: yes +RoxygenNote: 7.1.2 diff --git a/NEWS b/NEWS index b9e8c38..95a4872 100644 --- a/NEWS +++ b/NEWS @@ -1,79 +1,79 @@ -0.9.10 (26.10.2021) -=============== -* update for R4.2 - -0.9.9 (15.03.2021) -=============== -* bump version for rebuilding package (tested with R version 4.0.3) - -0.9.8-1 (23.05.2018) -=============== -* Fix 'xl.read.file' - it reads hidden sheets incorrectly. Thanks for reporting to Katie McCarron. -* Add functions 'xl.sheet.show'/'xl.sheet.hide'/'xl.sheet.visible' to manage sheets visibility (very hidden sheet is not supported) -* Add argument 'write.res.password' for xl.workbook.open/xl.workbook.save/xl.read.file/xl.save.file for reading/writing Excel files with second password (issue #11) -* Add new function: xl.sheet.name - for getting/setting active sheet name -* Add new function: xl.sheet.duplicate (issue #14) -* Now in R_Connection_Examples.xlsm we use default version of R, not 32-bit version (issue #13) - -0.9.7 (30.04.2017) -=============== -* Add option to get full path to workbooks (https://github.com/gdemin/excel.link/issues/7) -* Now xl.workbook.open doesn't try to open already open workbook (https://github.com/gdemin/excel.link/issues/6) -* Add xl(*)n family of functions. They create new sheet before output. -* Add very basic formatting support via xl.property -* Add xl.write method for 'etable' class from 'expss' package - https://gdemin.github.io/expss/ - -0.9.5 (24.09.2016) -=============== -* Fixes an issue with multibyte character encoding (fix from soeque1 https://github.com/soeque1) -* Fixes an issue with two workbooks after xl.workbooks.add/xl.workbooks.open - - -0.9.4 (12.04.2016) -=============== -* Fixes a GCC warning and linking error from gcc v4.9.3 (fix by Jim Hester) - -0.9.3 (06.12.2015) -=============== -* Make Excel examples compatible with 64-bit Excel version. -* Remove 'emf' format from current.graphics - -0.9.1 (14.07.2015) -=============== -* Fix converstion of #NUM! and other Excel errors. Now they are converted to NaN. -* Add basic datetime supports -* Add abitility to name pictures in Excel - so it can be updated from R -* xl.workbook.open/xl.read.file now can read files from URL -* Add active bindings to Excel ranges - -0.8.1 (06.05.2015) -=============== -* RDCOMClient integration -* options(excel_hwnd) to get specific Excel instance - -0.7.5 (25.04.2015) -=============== -* RStudio compatibility fix -* Switch to RDoxygen for documentation -* Release on Github -* Excel examples -* Reading/writing password-protected files - -0.6 (04.09.2013) -================ -* Added functions xl.read.file, xl.save.file -* Added filename argument in current.graphics - -0.5.5 (12.04.2013) -================= -* Compatibilty fix for R3.0 release - -0.5.4 (13.08.2012) -================== -* current.graphics now insert picture instead of link to the file -* aaa[condition,new.var] = data now works properly - -0.5 (19.11.2011) -================ -* initial release - +0.9.10 (26.10.2021) +=============== +* update for R4.2 + +0.9.9 (15.03.2021) +=============== +* bump version for rebuilding package (tested with R version 4.0.3) + +0.9.8-1 (23.05.2018) +=============== +* Fix 'xl.read.file' - it reads hidden sheets incorrectly. Thanks for reporting to Katie McCarron. +* Add functions 'xl.sheet.show'/'xl.sheet.hide'/'xl.sheet.visible' to manage sheets visibility (very hidden sheet is not supported) +* Add argument 'write.res.password' for xl.workbook.open/xl.workbook.save/xl.read.file/xl.save.file for reading/writing Excel files with second password (issue #11) +* Add new function: xl.sheet.name - for getting/setting active sheet name +* Add new function: xl.sheet.duplicate (issue #14) +* Now in R_Connection_Examples.xlsm we use default version of R, not 32-bit version (issue #13) + +0.9.7 (30.04.2017) +=============== +* Add option to get full path to workbooks (https://github.com/gdemin/excel.link/issues/7) +* Now xl.workbook.open doesn't try to open already open workbook (https://github.com/gdemin/excel.link/issues/6) +* Add xl(*)n family of functions. They create new sheet before output. +* Add very basic formatting support via xl.property +* Add xl.write method for 'etable' class from 'expss' package - https://gdemin.github.io/expss/ + +0.9.5 (24.09.2016) +=============== +* Fixes an issue with multibyte character encoding (fix from soeque1 https://github.com/soeque1) +* Fixes an issue with two workbooks after xl.workbooks.add/xl.workbooks.open + + +0.9.4 (12.04.2016) +=============== +* Fixes a GCC warning and linking error from gcc v4.9.3 (fix by Jim Hester) + +0.9.3 (06.12.2015) +=============== +* Make Excel examples compatible with 64-bit Excel version. +* Remove 'emf' format from current.graphics + +0.9.1 (14.07.2015) +=============== +* Fix converstion of #NUM! and other Excel errors. Now they are converted to NaN. +* Add basic datetime supports +* Add abitility to name pictures in Excel - so it can be updated from R +* xl.workbook.open/xl.read.file now can read files from URL +* Add active bindings to Excel ranges + +0.8.1 (06.05.2015) +=============== +* RDCOMClient integration +* options(excel_hwnd) to get specific Excel instance + +0.7.5 (25.04.2015) +=============== +* RStudio compatibility fix +* Switch to RDoxygen for documentation +* Release on Github +* Excel examples +* Reading/writing password-protected files + +0.6 (04.09.2013) +================ +* Added functions xl.read.file, xl.save.file +* Added filename argument in current.graphics + +0.5.5 (12.04.2013) +================= +* Compatibilty fix for R3.0 release + +0.5.4 (13.08.2012) +================== +* current.graphics now insert picture instead of link to the file +* aaa[condition,new.var] = data now works properly + +0.5 (19.11.2011) +================ +* initial release + diff --git a/src/COMError.cpp b/src/COMError.cpp index bffab5b..6cb1a43 100644 --- a/src/COMError.cpp +++ b/src/COMError.cpp @@ -1,597 +1,597 @@ -// # Package: RDCOMClient -// # Version: 0.93-0.2 -// # Title: R-DCOM Client -// # Author: Duncan Temple Lang -// # Maintainer: Duncan Temple Lang -// # Description: Provides dynamic client-side access to (D)COM applications from within R. -// # License: GPL-2 -// # Collate: classes.R COMLists.S COMError.R com.R debug.S zzz.R runTime.S -// # URL: http://www.omegahat.net/RDCOMClient, http://www.omegahat.net -// # http://www.omegahat.net/bugs -// Some parts of code by https://github.com/jototland/ jototland@gmail.com - -#include "RCOMObject.h" -#include -#include -#include /* sprintf() */ - -#include - -#include /* for Rf_error and Rf_warning */ - -#ifdef R_PROBLEM_BUFSIZE -#undef R_PROBLEM_BUFSIZE -#endif -#ifdef PROBLEM -#undef PROBLEM -#endif - -#ifdef MESSAGE -#undef MESSAGE -#endif -#ifdef RECOVER -#undef RECOVER -#endif - - -#ifdef WARNING -#undef WARNING -#endif -#ifdef LOCAL_EVALUATOR -#undef LOCAL_EVALUATOR -#endif - -#ifdef NULL_ENTRY -#undef NULL_ENTRY -#endif - - -#ifdef WARN -#undef WARN -#endif -#ifdef ERROR -#undef ERROR -#endif - - -#define R_PROBLEM_BUFSIZE 4096 -/* Parentheses added for FC4 with gcc4 and -D_FORTIFY_SOURCE=2 */ -#define PROBLEM {char R_problem_buf[R_PROBLEM_BUFSIZE];(snprintf)(R_problem_buf, R_PROBLEM_BUFSIZE, -#define MESSAGE {char R_problem_buf[R_PROBLEM_BUFSIZE];(snprintf)(R_problem_buf, R_PROBLEM_BUFSIZE, -#define ERROR ),Rf_error(R_problem_buf);} -#define RECOVER(x) ),Rf_error(R_problem_buf);} -#define WARNING(x) ),Rf_warning(R_problem_buf);} -#define LOCAL_EVALUATOR /**/ -#define NULL_ENTRY /**/ -#define WARN WARNING(NULL) - -extern "C" int RDCOM_WriteErrors; -int RDCOM_WriteErrors = 1; - -extern "C" -SEXP -RDCOM_setWriteError(SEXP value) -{ - int tmp = RDCOM_WriteErrors; - RDCOM_WriteErrors = asLogical(value); - return(ScalarLogical(tmp)); -} - -extern "C" -SEXP -RDCOM_getWriteError(SEXP value) -{ - return(ScalarLogical(RDCOM_WriteErrors)); -} - - - -FILE * -getErrorFILE() -{ - static FILE *f = NULL; - - if (f) - return f; - - TCHAR path[MAX_PATH]; - DWORD result; - - result = GetTempPath(MAX_PATH, path); - - if (result > MAX_PATH-10 || result == 0) { - f = stderr; - } else { - lstrcat(path, _T("RDCOM.err")); - f = fopen(path, "a"); - if (!f) { - f = stderr; - } - } - - return(f); -} - -extern "C" { -SEXP R_createCOMErrorCodes(); -} - -/* Taken from ErrorUtils.cpp in PyWin32 distribution. */ -#include "oaidl.h" - - - struct HRESULT_ENTRY - { - HRESULT hr; - LPCTSTR lpszName; - }; - #define MAKE_HRESULT_ENTRY(hr) { hr, (#hr) } - static const HRESULT_ENTRY hrNameTable[] = - { - MAKE_HRESULT_ENTRY(S_OK), - MAKE_HRESULT_ENTRY(S_FALSE), - - MAKE_HRESULT_ENTRY(CACHE_S_FORMATETC_NOTSUPPORTED), - MAKE_HRESULT_ENTRY(CACHE_S_SAMECACHE), - MAKE_HRESULT_ENTRY(CACHE_S_SOMECACHES_NOTUPDATED), - MAKE_HRESULT_ENTRY(CONVERT10_S_NO_PRESENTATION), - MAKE_HRESULT_ENTRY(DATA_S_SAMEFORMATETC), - MAKE_HRESULT_ENTRY(DRAGDROP_S_CANCEL), - MAKE_HRESULT_ENTRY(DRAGDROP_S_DROP), - MAKE_HRESULT_ENTRY(DRAGDROP_S_USEDEFAULTCURSORS), - MAKE_HRESULT_ENTRY(INPLACE_S_TRUNCATED), - MAKE_HRESULT_ENTRY(MK_S_HIM), - MAKE_HRESULT_ENTRY(MK_S_ME), - MAKE_HRESULT_ENTRY(MK_S_MONIKERALREADYREGISTERED), - MAKE_HRESULT_ENTRY(MK_S_REDUCED_TO_SELF), - MAKE_HRESULT_ENTRY(MK_S_US), - MAKE_HRESULT_ENTRY(OLE_S_MAC_CLIPFORMAT), - MAKE_HRESULT_ENTRY(OLE_S_STATIC), - MAKE_HRESULT_ENTRY(OLE_S_USEREG), - MAKE_HRESULT_ENTRY(OLEOBJ_S_CANNOT_DOVERB_NOW), - MAKE_HRESULT_ENTRY(OLEOBJ_S_INVALIDHWND), - MAKE_HRESULT_ENTRY(OLEOBJ_S_INVALIDVERB), - MAKE_HRESULT_ENTRY(OLEOBJ_S_LAST), - MAKE_HRESULT_ENTRY(STG_S_CONVERTED), - MAKE_HRESULT_ENTRY(VIEW_S_ALREADY_FROZEN), - - MAKE_HRESULT_ENTRY(E_UNEXPECTED), - MAKE_HRESULT_ENTRY(E_NOTIMPL), - MAKE_HRESULT_ENTRY(E_OUTOFMEMORY), - MAKE_HRESULT_ENTRY(E_INVALIDARG), - MAKE_HRESULT_ENTRY(E_NOINTERFACE), - MAKE_HRESULT_ENTRY(E_POINTER), - MAKE_HRESULT_ENTRY(E_HANDLE), - MAKE_HRESULT_ENTRY(E_ABORT), - MAKE_HRESULT_ENTRY(E_FAIL), - MAKE_HRESULT_ENTRY(E_ACCESSDENIED), - - MAKE_HRESULT_ENTRY(CACHE_E_NOCACHE_UPDATED), - MAKE_HRESULT_ENTRY(CLASS_E_CLASSNOTAVAILABLE), - MAKE_HRESULT_ENTRY(CLASS_E_NOAGGREGATION), - MAKE_HRESULT_ENTRY(CLIPBRD_E_BAD_DATA), - MAKE_HRESULT_ENTRY(CLIPBRD_E_CANT_CLOSE), - MAKE_HRESULT_ENTRY(CLIPBRD_E_CANT_EMPTY), - MAKE_HRESULT_ENTRY(CLIPBRD_E_CANT_OPEN), - MAKE_HRESULT_ENTRY(CLIPBRD_E_CANT_SET), - MAKE_HRESULT_ENTRY(CO_E_ALREADYINITIALIZED), - MAKE_HRESULT_ENTRY(CO_E_APPDIDNTREG), - MAKE_HRESULT_ENTRY(CO_E_APPNOTFOUND), - MAKE_HRESULT_ENTRY(CO_E_APPSINGLEUSE), - MAKE_HRESULT_ENTRY(CO_E_BAD_PATH), - MAKE_HRESULT_ENTRY(CO_E_CANTDETERMINECLASS), - MAKE_HRESULT_ENTRY(CO_E_CLASS_CREATE_FAILED), - MAKE_HRESULT_ENTRY(CO_E_CLASSSTRING), - MAKE_HRESULT_ENTRY(CO_E_DLLNOTFOUND), - MAKE_HRESULT_ENTRY(CO_E_ERRORINAPP), - MAKE_HRESULT_ENTRY(CO_E_ERRORINDLL), - MAKE_HRESULT_ENTRY(CO_E_IIDSTRING), - MAKE_HRESULT_ENTRY(CO_E_NOTINITIALIZED), - MAKE_HRESULT_ENTRY(CO_E_OBJISREG), - MAKE_HRESULT_ENTRY(CO_E_OBJNOTCONNECTED), - MAKE_HRESULT_ENTRY(CO_E_OBJNOTREG), - MAKE_HRESULT_ENTRY(CO_E_OBJSRV_RPC_FAILURE), - MAKE_HRESULT_ENTRY(CO_E_SCM_ERROR), - MAKE_HRESULT_ENTRY(CO_E_SCM_RPC_FAILURE), - MAKE_HRESULT_ENTRY(CO_E_SERVER_EXEC_FAILURE), - MAKE_HRESULT_ENTRY(CO_E_SERVER_STOPPING), - MAKE_HRESULT_ENTRY(CO_E_WRONGOSFORAPP), - MAKE_HRESULT_ENTRY(CONVERT10_E_OLESTREAM_BITMAP_TO_DIB), - MAKE_HRESULT_ENTRY(CONVERT10_E_OLESTREAM_FMT), - MAKE_HRESULT_ENTRY(CONVERT10_E_OLESTREAM_GET), - MAKE_HRESULT_ENTRY(CONVERT10_E_OLESTREAM_PUT), - MAKE_HRESULT_ENTRY(CONVERT10_E_STG_DIB_TO_BITMAP), - MAKE_HRESULT_ENTRY(CONVERT10_E_STG_FMT), - MAKE_HRESULT_ENTRY(CONVERT10_E_STG_NO_STD_STREAM), - MAKE_HRESULT_ENTRY(DISP_E_ARRAYISLOCKED), - MAKE_HRESULT_ENTRY(DISP_E_BADCALLEE), - MAKE_HRESULT_ENTRY(DISP_E_BADINDEX), - MAKE_HRESULT_ENTRY(DISP_E_BADPARAMCOUNT), - MAKE_HRESULT_ENTRY(DISP_E_BADVARTYPE), - MAKE_HRESULT_ENTRY(DISP_E_EXCEPTION), - MAKE_HRESULT_ENTRY(DISP_E_MEMBERNOTFOUND), - MAKE_HRESULT_ENTRY(DISP_E_NONAMEDARGS), - MAKE_HRESULT_ENTRY(DISP_E_NOTACOLLECTION), - MAKE_HRESULT_ENTRY(DISP_E_OVERFLOW), - MAKE_HRESULT_ENTRY(DISP_E_PARAMNOTFOUND), - MAKE_HRESULT_ENTRY(DISP_E_PARAMNOTOPTIONAL), - MAKE_HRESULT_ENTRY(DISP_E_TYPEMISMATCH), - MAKE_HRESULT_ENTRY(DISP_E_UNKNOWNINTERFACE), - MAKE_HRESULT_ENTRY(DISP_E_UNKNOWNLCID), - MAKE_HRESULT_ENTRY(DISP_E_UNKNOWNNAME), - MAKE_HRESULT_ENTRY(DRAGDROP_E_ALREADYREGISTERED), - MAKE_HRESULT_ENTRY(DRAGDROP_E_INVALIDHWND), - MAKE_HRESULT_ENTRY(DRAGDROP_E_NOTREGISTERED), - MAKE_HRESULT_ENTRY(DV_E_CLIPFORMAT), - MAKE_HRESULT_ENTRY(DV_E_DVASPECT), - MAKE_HRESULT_ENTRY(DV_E_DVTARGETDEVICE), - MAKE_HRESULT_ENTRY(DV_E_DVTARGETDEVICE_SIZE), - MAKE_HRESULT_ENTRY(DV_E_FORMATETC), - MAKE_HRESULT_ENTRY(DV_E_LINDEX), - MAKE_HRESULT_ENTRY(DV_E_NOIVIEWOBJECT), - MAKE_HRESULT_ENTRY(DV_E_STATDATA), - MAKE_HRESULT_ENTRY(DV_E_STGMEDIUM), - MAKE_HRESULT_ENTRY(DV_E_TYMED), - MAKE_HRESULT_ENTRY(INPLACE_E_NOTOOLSPACE), - MAKE_HRESULT_ENTRY(INPLACE_E_NOTUNDOABLE), - MAKE_HRESULT_ENTRY(MEM_E_INVALID_LINK), - MAKE_HRESULT_ENTRY(MEM_E_INVALID_ROOT), - MAKE_HRESULT_ENTRY(MEM_E_INVALID_SIZE), - MAKE_HRESULT_ENTRY(MK_E_CANTOPENFILE), - MAKE_HRESULT_ENTRY(MK_E_CONNECTMANUALLY), - MAKE_HRESULT_ENTRY(MK_E_ENUMERATION_FAILED), - MAKE_HRESULT_ENTRY(MK_E_EXCEEDEDDEADLINE), - MAKE_HRESULT_ENTRY(MK_E_INTERMEDIATEINTERFACENOTSUPPORTED), - MAKE_HRESULT_ENTRY(MK_E_INVALIDEXTENSION), - MAKE_HRESULT_ENTRY(MK_E_MUSTBOTHERUSER), - MAKE_HRESULT_ENTRY(MK_E_NEEDGENERIC), - MAKE_HRESULT_ENTRY(MK_E_NO_NORMALIZED), - MAKE_HRESULT_ENTRY(MK_E_NOINVERSE), - MAKE_HRESULT_ENTRY(MK_E_NOOBJECT), - MAKE_HRESULT_ENTRY(MK_E_NOPREFIX), - MAKE_HRESULT_ENTRY(MK_E_NOSTORAGE), - MAKE_HRESULT_ENTRY(MK_E_NOTBINDABLE), - MAKE_HRESULT_ENTRY(MK_E_NOTBOUND), - MAKE_HRESULT_ENTRY(MK_E_SYNTAX), - MAKE_HRESULT_ENTRY(MK_E_UNAVAILABLE), - MAKE_HRESULT_ENTRY(OLE_E_ADVF), - MAKE_HRESULT_ENTRY(OLE_E_ADVISENOTSUPPORTED), - MAKE_HRESULT_ENTRY(OLE_E_BLANK), - MAKE_HRESULT_ENTRY(OLE_E_CANT_BINDTOSOURCE), - MAKE_HRESULT_ENTRY(OLE_E_CANT_GETMONIKER), - MAKE_HRESULT_ENTRY(OLE_E_CANTCONVERT), - MAKE_HRESULT_ENTRY(OLE_E_CLASSDIFF), - MAKE_HRESULT_ENTRY(OLE_E_ENUM_NOMORE), - MAKE_HRESULT_ENTRY(OLE_E_INVALIDHWND), - MAKE_HRESULT_ENTRY(OLE_E_INVALIDRECT), - MAKE_HRESULT_ENTRY(OLE_E_NOCACHE), - MAKE_HRESULT_ENTRY(OLE_E_NOCONNECTION), - MAKE_HRESULT_ENTRY(OLE_E_NOSTORAGE), - MAKE_HRESULT_ENTRY(OLE_E_NOT_INPLACEACTIVE), - MAKE_HRESULT_ENTRY(OLE_E_NOTRUNNING), - MAKE_HRESULT_ENTRY(OLE_E_OLEVERB), - MAKE_HRESULT_ENTRY(OLE_E_PROMPTSAVECANCELLED), - MAKE_HRESULT_ENTRY(OLE_E_STATIC), - MAKE_HRESULT_ENTRY(OLE_E_WRONGCOMPOBJ), - MAKE_HRESULT_ENTRY(OLEOBJ_E_INVALIDVERB), - MAKE_HRESULT_ENTRY(OLEOBJ_E_NOVERBS), - MAKE_HRESULT_ENTRY(REGDB_E_CLASSNOTREG), - MAKE_HRESULT_ENTRY(REGDB_E_IIDNOTREG), - MAKE_HRESULT_ENTRY(REGDB_E_INVALIDVALUE), - MAKE_HRESULT_ENTRY(REGDB_E_KEYMISSING), - MAKE_HRESULT_ENTRY(REGDB_E_READREGDB), - MAKE_HRESULT_ENTRY(REGDB_E_WRITEREGDB), - MAKE_HRESULT_ENTRY(RPC_E_ATTEMPTED_MULTITHREAD), - MAKE_HRESULT_ENTRY(RPC_E_CALL_CANCELED), - MAKE_HRESULT_ENTRY(RPC_E_CALL_REJECTED), - MAKE_HRESULT_ENTRY(RPC_E_CANTCALLOUT_AGAIN), - MAKE_HRESULT_ENTRY(RPC_E_CANTCALLOUT_INASYNCCALL), - MAKE_HRESULT_ENTRY(RPC_E_CANTCALLOUT_INEXTERNALCALL), - MAKE_HRESULT_ENTRY(RPC_E_CANTCALLOUT_ININPUTSYNCCALL), - MAKE_HRESULT_ENTRY(RPC_E_CANTPOST_INSENDCALL), - MAKE_HRESULT_ENTRY(RPC_E_CANTTRANSMIT_CALL), - MAKE_HRESULT_ENTRY(RPC_E_CHANGED_MODE), - MAKE_HRESULT_ENTRY(RPC_E_CLIENT_CANTMARSHAL_DATA), - MAKE_HRESULT_ENTRY(RPC_E_CLIENT_CANTUNMARSHAL_DATA), - MAKE_HRESULT_ENTRY(RPC_E_CLIENT_DIED), - MAKE_HRESULT_ENTRY(RPC_E_CONNECTION_TERMINATED), - MAKE_HRESULT_ENTRY(RPC_E_DISCONNECTED), - MAKE_HRESULT_ENTRY(RPC_E_FAULT), - MAKE_HRESULT_ENTRY(RPC_E_INVALID_CALLDATA), - MAKE_HRESULT_ENTRY(RPC_E_INVALID_DATA), - MAKE_HRESULT_ENTRY(RPC_E_INVALID_DATAPACKET), - MAKE_HRESULT_ENTRY(RPC_E_INVALID_PARAMETER), - MAKE_HRESULT_ENTRY(RPC_E_INVALIDMETHOD), - MAKE_HRESULT_ENTRY(RPC_E_NOT_REGISTERED), - MAKE_HRESULT_ENTRY(RPC_E_OUT_OF_RESOURCES), - MAKE_HRESULT_ENTRY(RPC_E_RETRY), - MAKE_HRESULT_ENTRY(RPC_E_SERVER_CANTMARSHAL_DATA), - MAKE_HRESULT_ENTRY(RPC_E_SERVER_CANTUNMARSHAL_DATA), - MAKE_HRESULT_ENTRY(RPC_E_SERVER_DIED), - MAKE_HRESULT_ENTRY(RPC_E_SERVER_DIED_DNE), - MAKE_HRESULT_ENTRY(RPC_E_SERVERCALL_REJECTED), - MAKE_HRESULT_ENTRY(RPC_E_SERVERCALL_RETRYLATER), - MAKE_HRESULT_ENTRY(RPC_E_SERVERFAULT), - MAKE_HRESULT_ENTRY(RPC_E_SYS_CALL_FAILED), - MAKE_HRESULT_ENTRY(RPC_E_THREAD_NOT_INIT), - MAKE_HRESULT_ENTRY(RPC_E_UNEXPECTED), - MAKE_HRESULT_ENTRY(RPC_E_WRONG_THREAD), - MAKE_HRESULT_ENTRY(STG_E_ABNORMALAPIEXIT), - MAKE_HRESULT_ENTRY(STG_E_ACCESSDENIED), - MAKE_HRESULT_ENTRY(STG_E_CANTSAVE), - MAKE_HRESULT_ENTRY(STG_E_DISKISWRITEPROTECTED), - MAKE_HRESULT_ENTRY(STG_E_EXTANTMARSHALLINGS), - MAKE_HRESULT_ENTRY(STG_E_FILEALREADYEXISTS), - MAKE_HRESULT_ENTRY(STG_E_FILENOTFOUND), - MAKE_HRESULT_ENTRY(STG_E_INSUFFICIENTMEMORY), - MAKE_HRESULT_ENTRY(STG_E_INUSE), - MAKE_HRESULT_ENTRY(STG_E_INVALIDFLAG), - MAKE_HRESULT_ENTRY(STG_E_INVALIDFUNCTION), - MAKE_HRESULT_ENTRY(STG_E_INVALIDHANDLE), - MAKE_HRESULT_ENTRY(STG_E_INVALIDHEADER), - MAKE_HRESULT_ENTRY(STG_E_INVALIDNAME), - MAKE_HRESULT_ENTRY(STG_E_INVALIDPARAMETER), - MAKE_HRESULT_ENTRY(STG_E_INVALIDPOINTER), - MAKE_HRESULT_ENTRY(STG_E_LOCKVIOLATION), - MAKE_HRESULT_ENTRY(STG_E_MEDIUMFULL), - MAKE_HRESULT_ENTRY(STG_E_NOMOREFILES), - MAKE_HRESULT_ENTRY(STG_E_NOTCURRENT), - MAKE_HRESULT_ENTRY(STG_E_NOTFILEBASEDSTORAGE), - MAKE_HRESULT_ENTRY(STG_E_OLDDLL), - MAKE_HRESULT_ENTRY(STG_E_OLDFORMAT), - MAKE_HRESULT_ENTRY(STG_E_PATHNOTFOUND), - MAKE_HRESULT_ENTRY(STG_E_READFAULT), - MAKE_HRESULT_ENTRY(STG_E_REVERTED), - MAKE_HRESULT_ENTRY(STG_E_SEEKERROR), - MAKE_HRESULT_ENTRY(STG_E_SHAREREQUIRED), - MAKE_HRESULT_ENTRY(STG_E_SHAREVIOLATION), - MAKE_HRESULT_ENTRY(STG_E_TOOMANYOPENFILES), - MAKE_HRESULT_ENTRY(STG_E_UNIMPLEMENTEDFUNCTION), - MAKE_HRESULT_ENTRY(STG_E_UNKNOWN), - MAKE_HRESULT_ENTRY(STG_E_WRITEFAULT), - MAKE_HRESULT_ENTRY(TYPE_E_AMBIGUOUSNAME), - MAKE_HRESULT_ENTRY(TYPE_E_BADMODULEKIND), - MAKE_HRESULT_ENTRY(TYPE_E_BUFFERTOOSMALL), - MAKE_HRESULT_ENTRY(TYPE_E_CANTCREATETMPFILE), - MAKE_HRESULT_ENTRY(TYPE_E_CANTLOADLIBRARY), - MAKE_HRESULT_ENTRY(TYPE_E_CIRCULARTYPE), - MAKE_HRESULT_ENTRY(TYPE_E_DLLFUNCTIONNOTFOUND), - MAKE_HRESULT_ENTRY(TYPE_E_DUPLICATEID), - MAKE_HRESULT_ENTRY(TYPE_E_ELEMENTNOTFOUND), - MAKE_HRESULT_ENTRY(TYPE_E_INCONSISTENTPROPFUNCS), - MAKE_HRESULT_ENTRY(TYPE_E_INVALIDSTATE), - MAKE_HRESULT_ENTRY(TYPE_E_INVDATAREAD), - MAKE_HRESULT_ENTRY(TYPE_E_IOERROR), - MAKE_HRESULT_ENTRY(TYPE_E_LIBNOTREGISTERED), - MAKE_HRESULT_ENTRY(TYPE_E_NAMECONFLICT), - MAKE_HRESULT_ENTRY(TYPE_E_OUTOFBOUNDS), - MAKE_HRESULT_ENTRY(TYPE_E_QUALIFIEDNAMEDISALLOWED), - MAKE_HRESULT_ENTRY(TYPE_E_REGISTRYACCESS), - MAKE_HRESULT_ENTRY(TYPE_E_SIZETOOBIG), - MAKE_HRESULT_ENTRY(TYPE_E_TYPEMISMATCH), - MAKE_HRESULT_ENTRY(TYPE_E_UNDEFINEDTYPE), - MAKE_HRESULT_ENTRY(TYPE_E_UNKNOWNLCID), - MAKE_HRESULT_ENTRY(TYPE_E_UNSUPFORMAT), - MAKE_HRESULT_ENTRY(TYPE_E_WRONGTYPEKIND), - MAKE_HRESULT_ENTRY(VIEW_E_DRAW), - -#if NOT_AVAILABLE - MAKE_HRESULT_ENTRY(CONNECT_E_NOCONNECTION), - MAKE_HRESULT_ENTRY(CONNECT_E_ADVISELIMIT), - MAKE_HRESULT_ENTRY(CONNECT_E_CANNOTCONNECT), - MAKE_HRESULT_ENTRY(CONNECT_E_OVERRIDDEN), -#endif - -#ifndef NO_PYCOM_IPROVIDECLASSINFO - MAKE_HRESULT_ENTRY(CLASS_E_NOTLICENSED), - MAKE_HRESULT_ENTRY(CLASS_E_NOAGGREGATION), - MAKE_HRESULT_ENTRY(CLASS_E_CLASSNOTAVAILABLE), -#endif // NO_PYCOM_IPROVIDECLASSINFO - -#ifndef MS_WINCE // ?? -#if AVAILABLE - MAKE_HRESULT_ENTRY(CTL_E_ILLEGALFUNCTIONCALL ), - MAKE_HRESULT_ENTRY(CTL_E_OVERFLOW ), - MAKE_HRESULT_ENTRY(CTL_E_OUTOFMEMORY ), - MAKE_HRESULT_ENTRY(CTL_E_DIVISIONBYZERO ), - MAKE_HRESULT_ENTRY(CTL_E_OUTOFSTRINGSPACE ), - MAKE_HRESULT_ENTRY(CTL_E_OUTOFSTACKSPACE ), - MAKE_HRESULT_ENTRY(CTL_E_BADFILENAMEORNUMBER ), - MAKE_HRESULT_ENTRY(CTL_E_FILENOTFOUND ), - MAKE_HRESULT_ENTRY(CTL_E_BADFILEMODE ), - MAKE_HRESULT_ENTRY(CTL_E_FILEALREADYOPEN ), - MAKE_HRESULT_ENTRY(CTL_E_DEVICEIOERROR ), - MAKE_HRESULT_ENTRY(CTL_E_FILEALREADYEXISTS ), - MAKE_HRESULT_ENTRY(CTL_E_BADRECORDLENGTH ), - MAKE_HRESULT_ENTRY(CTL_E_DISKFULL ), - MAKE_HRESULT_ENTRY(CTL_E_BADRECORDNUMBER ), - MAKE_HRESULT_ENTRY(CTL_E_BADFILENAME ), - MAKE_HRESULT_ENTRY(CTL_E_TOOMANYFILES ), - MAKE_HRESULT_ENTRY(CTL_E_DEVICEUNAVAILABLE ), - MAKE_HRESULT_ENTRY(CTL_E_PERMISSIONDENIED ), - MAKE_HRESULT_ENTRY(CTL_E_DISKNOTREADY ), - MAKE_HRESULT_ENTRY(CTL_E_PATHFILEACCESSERROR ), - MAKE_HRESULT_ENTRY(CTL_E_PATHNOTFOUND ), - MAKE_HRESULT_ENTRY(CTL_E_INVALIDPATTERNSTRING ), - MAKE_HRESULT_ENTRY(CTL_E_INVALIDUSEOFNULL ), - MAKE_HRESULT_ENTRY(CTL_E_INVALIDFILEFORMAT ), - MAKE_HRESULT_ENTRY(CTL_E_INVALIDPROPERTYVALUE ), - MAKE_HRESULT_ENTRY(CTL_E_INVALIDPROPERTYARRAYINDEX), - MAKE_HRESULT_ENTRY(CTL_E_SETNOTSUPPORTEDATRUNTIME ), - MAKE_HRESULT_ENTRY(CTL_E_SETNOTSUPPORTED ), - MAKE_HRESULT_ENTRY(CTL_E_NEEDPROPERTYARRAYINDEX ), - MAKE_HRESULT_ENTRY(CTL_E_SETNOTPERMITTED ), - MAKE_HRESULT_ENTRY(CTL_E_GETNOTSUPPORTEDATRUNTIME ), - MAKE_HRESULT_ENTRY(CTL_E_GETNOTSUPPORTED ), - MAKE_HRESULT_ENTRY(CTL_E_PROPERTYNOTFOUND ), - MAKE_HRESULT_ENTRY(CTL_E_INVALIDCLIPBOARDFORMAT ), - MAKE_HRESULT_ENTRY(CTL_E_INVALIDPICTURE ), - MAKE_HRESULT_ENTRY(CTL_E_PRINTERERROR ), - MAKE_HRESULT_ENTRY(CTL_E_CANTSAVEFILETOTEMP ), - MAKE_HRESULT_ENTRY(CTL_E_SEARCHTEXTNOTFOUND ), - MAKE_HRESULT_ENTRY(CTL_E_REPLACEMENTSTOOLONG ), -#endif -#endif // MS_WINCE - }; - #undef MAKE_HRESULT_ENTRY - - -#ifndef _countof -#define _countof(array) (sizeof(array)/sizeof(array[0])) -#endif -void GetScodeString(HRESULT hr, LPTSTR buf, int bufSize) -{ - // first ask the OS to give it to us.. - // ### should we get the Unicode version instead? - int numCopied = ::FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, NULL, hr, 0, buf, bufSize, NULL ); - if (numCopied>0) { - if (numCopied2 && (buf[numCopied-2]=='\n'||buf[numCopied-2]=='\r')) - buf[numCopied-2] = '\0'; - } - return; - } - - // else look for it in the table - for (unsigned int i = 0; i < _countof(hrNameTable); i++) - { - if (hr == hrNameTable[i].hr) { - strncpy(buf, hrNameTable[i].lpszName, bufSize); - return; - } - } - // not found - make one up - sprintf(buf, ("OLE error 0x%08lx"), hr); -} - - - - -void -COMError(HRESULT hr) -{ - TCHAR buf[512]; - GetScodeString(hr, buf, sizeof(buf)/sizeof(buf[0])); - /* - PROBLEM buf - ERROR; - */ - SEXP e; - PROTECT(e = allocVector(LANGSXP, 3)); - SETCAR(e, Rf_install("COMStop")); - SETCAR(CDR(e), mkString(buf)); - SETCAR(CDR(CDR(e)), ScalarInteger(hr)); - Rf_eval(e, R_GlobalEnv); - UNPROTECT(1); /* Won't come back to here. */ -} - - - - -/* 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, " %lX \n", 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_createCOMErrorCodes() -{ - SEXP ans, names; - int n; - n = _countof(hrNameTable); - PROTECT(ans = allocVector(REALSXP, n)); - PROTECT(names = allocVector(STRSXP, n)); - for (int i = 0; i < n; i++) - { - REAL(ans)[i] = (double) hrNameTable[i].hr; - SET_STRING_ELT(names, i, COPY_TO_USER_STRING(hrNameTable[i].lpszName)); - } - - SET_NAMES(ans, names); - UNPROTECT(2); - return(ans); -} +// # Package: RDCOMClient +// # Version: 0.93-0.2 +// # Title: R-DCOM Client +// # Author: Duncan Temple Lang +// # Maintainer: Duncan Temple Lang +// # Description: Provides dynamic client-side access to (D)COM applications from within R. +// # License: GPL-2 +// # Collate: classes.R COMLists.S COMError.R com.R debug.S zzz.R runTime.S +// # URL: http://www.omegahat.net/RDCOMClient, http://www.omegahat.net +// # http://www.omegahat.net/bugs +// Some parts of code by https://github.com/jototland/ jototland@gmail.com + +#include "RCOMObject.h" +#include +#include +#include /* sprintf() */ + +#include + +#include /* for Rf_error and Rf_warning */ + +#ifdef R_PROBLEM_BUFSIZE +#undef R_PROBLEM_BUFSIZE +#endif +#ifdef PROBLEM +#undef PROBLEM +#endif + +#ifdef MESSAGE +#undef MESSAGE +#endif +#ifdef RECOVER +#undef RECOVER +#endif + + +#ifdef WARNING +#undef WARNING +#endif +#ifdef LOCAL_EVALUATOR +#undef LOCAL_EVALUATOR +#endif + +#ifdef NULL_ENTRY +#undef NULL_ENTRY +#endif + + +#ifdef WARN +#undef WARN +#endif +#ifdef ERROR +#undef ERROR +#endif + + +#define R_PROBLEM_BUFSIZE 4096 +/* Parentheses added for FC4 with gcc4 and -D_FORTIFY_SOURCE=2 */ +#define PROBLEM {char R_problem_buf[R_PROBLEM_BUFSIZE];(snprintf)(R_problem_buf, R_PROBLEM_BUFSIZE, +#define MESSAGE {char R_problem_buf[R_PROBLEM_BUFSIZE];(snprintf)(R_problem_buf, R_PROBLEM_BUFSIZE, +#define ERROR ),Rf_error(R_problem_buf);} +#define RECOVER(x) ),Rf_error(R_problem_buf);} +#define WARNING(x) ),Rf_warning(R_problem_buf);} +#define LOCAL_EVALUATOR /**/ +#define NULL_ENTRY /**/ +#define WARN WARNING(NULL) + +extern "C" int RDCOM_WriteErrors; +int RDCOM_WriteErrors = 1; + +extern "C" +SEXP +RDCOM_setWriteError(SEXP value) +{ + int tmp = RDCOM_WriteErrors; + RDCOM_WriteErrors = asLogical(value); + return(ScalarLogical(tmp)); +} + +extern "C" +SEXP +RDCOM_getWriteError(SEXP value) +{ + return(ScalarLogical(RDCOM_WriteErrors)); +} + + + +FILE * +getErrorFILE() +{ + static FILE *f = NULL; + + if (f) + return f; + + TCHAR path[MAX_PATH]; + DWORD result; + + result = GetTempPath(MAX_PATH, path); + + if (result > MAX_PATH-10 || result == 0) { + f = stderr; + } else { + lstrcat(path, _T("RDCOM.err")); + f = fopen(path, "a"); + if (!f) { + f = stderr; + } + } + + return(f); +} + +extern "C" { +SEXP R_createCOMErrorCodes(); +} + +/* Taken from ErrorUtils.cpp in PyWin32 distribution. */ +#include "oaidl.h" + + + struct HRESULT_ENTRY + { + HRESULT hr; + LPCTSTR lpszName; + }; + #define MAKE_HRESULT_ENTRY(hr) { hr, (#hr) } + static const HRESULT_ENTRY hrNameTable[] = + { + MAKE_HRESULT_ENTRY(S_OK), + MAKE_HRESULT_ENTRY(S_FALSE), + + MAKE_HRESULT_ENTRY(CACHE_S_FORMATETC_NOTSUPPORTED), + MAKE_HRESULT_ENTRY(CACHE_S_SAMECACHE), + MAKE_HRESULT_ENTRY(CACHE_S_SOMECACHES_NOTUPDATED), + MAKE_HRESULT_ENTRY(CONVERT10_S_NO_PRESENTATION), + MAKE_HRESULT_ENTRY(DATA_S_SAMEFORMATETC), + MAKE_HRESULT_ENTRY(DRAGDROP_S_CANCEL), + MAKE_HRESULT_ENTRY(DRAGDROP_S_DROP), + MAKE_HRESULT_ENTRY(DRAGDROP_S_USEDEFAULTCURSORS), + MAKE_HRESULT_ENTRY(INPLACE_S_TRUNCATED), + MAKE_HRESULT_ENTRY(MK_S_HIM), + MAKE_HRESULT_ENTRY(MK_S_ME), + MAKE_HRESULT_ENTRY(MK_S_MONIKERALREADYREGISTERED), + MAKE_HRESULT_ENTRY(MK_S_REDUCED_TO_SELF), + MAKE_HRESULT_ENTRY(MK_S_US), + MAKE_HRESULT_ENTRY(OLE_S_MAC_CLIPFORMAT), + MAKE_HRESULT_ENTRY(OLE_S_STATIC), + MAKE_HRESULT_ENTRY(OLE_S_USEREG), + MAKE_HRESULT_ENTRY(OLEOBJ_S_CANNOT_DOVERB_NOW), + MAKE_HRESULT_ENTRY(OLEOBJ_S_INVALIDHWND), + MAKE_HRESULT_ENTRY(OLEOBJ_S_INVALIDVERB), + MAKE_HRESULT_ENTRY(OLEOBJ_S_LAST), + MAKE_HRESULT_ENTRY(STG_S_CONVERTED), + MAKE_HRESULT_ENTRY(VIEW_S_ALREADY_FROZEN), + + MAKE_HRESULT_ENTRY(E_UNEXPECTED), + MAKE_HRESULT_ENTRY(E_NOTIMPL), + MAKE_HRESULT_ENTRY(E_OUTOFMEMORY), + MAKE_HRESULT_ENTRY(E_INVALIDARG), + MAKE_HRESULT_ENTRY(E_NOINTERFACE), + MAKE_HRESULT_ENTRY(E_POINTER), + MAKE_HRESULT_ENTRY(E_HANDLE), + MAKE_HRESULT_ENTRY(E_ABORT), + MAKE_HRESULT_ENTRY(E_FAIL), + MAKE_HRESULT_ENTRY(E_ACCESSDENIED), + + MAKE_HRESULT_ENTRY(CACHE_E_NOCACHE_UPDATED), + MAKE_HRESULT_ENTRY(CLASS_E_CLASSNOTAVAILABLE), + MAKE_HRESULT_ENTRY(CLASS_E_NOAGGREGATION), + MAKE_HRESULT_ENTRY(CLIPBRD_E_BAD_DATA), + MAKE_HRESULT_ENTRY(CLIPBRD_E_CANT_CLOSE), + MAKE_HRESULT_ENTRY(CLIPBRD_E_CANT_EMPTY), + MAKE_HRESULT_ENTRY(CLIPBRD_E_CANT_OPEN), + MAKE_HRESULT_ENTRY(CLIPBRD_E_CANT_SET), + MAKE_HRESULT_ENTRY(CO_E_ALREADYINITIALIZED), + MAKE_HRESULT_ENTRY(CO_E_APPDIDNTREG), + MAKE_HRESULT_ENTRY(CO_E_APPNOTFOUND), + MAKE_HRESULT_ENTRY(CO_E_APPSINGLEUSE), + MAKE_HRESULT_ENTRY(CO_E_BAD_PATH), + MAKE_HRESULT_ENTRY(CO_E_CANTDETERMINECLASS), + MAKE_HRESULT_ENTRY(CO_E_CLASS_CREATE_FAILED), + MAKE_HRESULT_ENTRY(CO_E_CLASSSTRING), + MAKE_HRESULT_ENTRY(CO_E_DLLNOTFOUND), + MAKE_HRESULT_ENTRY(CO_E_ERRORINAPP), + MAKE_HRESULT_ENTRY(CO_E_ERRORINDLL), + MAKE_HRESULT_ENTRY(CO_E_IIDSTRING), + MAKE_HRESULT_ENTRY(CO_E_NOTINITIALIZED), + MAKE_HRESULT_ENTRY(CO_E_OBJISREG), + MAKE_HRESULT_ENTRY(CO_E_OBJNOTCONNECTED), + MAKE_HRESULT_ENTRY(CO_E_OBJNOTREG), + MAKE_HRESULT_ENTRY(CO_E_OBJSRV_RPC_FAILURE), + MAKE_HRESULT_ENTRY(CO_E_SCM_ERROR), + MAKE_HRESULT_ENTRY(CO_E_SCM_RPC_FAILURE), + MAKE_HRESULT_ENTRY(CO_E_SERVER_EXEC_FAILURE), + MAKE_HRESULT_ENTRY(CO_E_SERVER_STOPPING), + MAKE_HRESULT_ENTRY(CO_E_WRONGOSFORAPP), + MAKE_HRESULT_ENTRY(CONVERT10_E_OLESTREAM_BITMAP_TO_DIB), + MAKE_HRESULT_ENTRY(CONVERT10_E_OLESTREAM_FMT), + MAKE_HRESULT_ENTRY(CONVERT10_E_OLESTREAM_GET), + MAKE_HRESULT_ENTRY(CONVERT10_E_OLESTREAM_PUT), + MAKE_HRESULT_ENTRY(CONVERT10_E_STG_DIB_TO_BITMAP), + MAKE_HRESULT_ENTRY(CONVERT10_E_STG_FMT), + MAKE_HRESULT_ENTRY(CONVERT10_E_STG_NO_STD_STREAM), + MAKE_HRESULT_ENTRY(DISP_E_ARRAYISLOCKED), + MAKE_HRESULT_ENTRY(DISP_E_BADCALLEE), + MAKE_HRESULT_ENTRY(DISP_E_BADINDEX), + MAKE_HRESULT_ENTRY(DISP_E_BADPARAMCOUNT), + MAKE_HRESULT_ENTRY(DISP_E_BADVARTYPE), + MAKE_HRESULT_ENTRY(DISP_E_EXCEPTION), + MAKE_HRESULT_ENTRY(DISP_E_MEMBERNOTFOUND), + MAKE_HRESULT_ENTRY(DISP_E_NONAMEDARGS), + MAKE_HRESULT_ENTRY(DISP_E_NOTACOLLECTION), + MAKE_HRESULT_ENTRY(DISP_E_OVERFLOW), + MAKE_HRESULT_ENTRY(DISP_E_PARAMNOTFOUND), + MAKE_HRESULT_ENTRY(DISP_E_PARAMNOTOPTIONAL), + MAKE_HRESULT_ENTRY(DISP_E_TYPEMISMATCH), + MAKE_HRESULT_ENTRY(DISP_E_UNKNOWNINTERFACE), + MAKE_HRESULT_ENTRY(DISP_E_UNKNOWNLCID), + MAKE_HRESULT_ENTRY(DISP_E_UNKNOWNNAME), + MAKE_HRESULT_ENTRY(DRAGDROP_E_ALREADYREGISTERED), + MAKE_HRESULT_ENTRY(DRAGDROP_E_INVALIDHWND), + MAKE_HRESULT_ENTRY(DRAGDROP_E_NOTREGISTERED), + MAKE_HRESULT_ENTRY(DV_E_CLIPFORMAT), + MAKE_HRESULT_ENTRY(DV_E_DVASPECT), + MAKE_HRESULT_ENTRY(DV_E_DVTARGETDEVICE), + MAKE_HRESULT_ENTRY(DV_E_DVTARGETDEVICE_SIZE), + MAKE_HRESULT_ENTRY(DV_E_FORMATETC), + MAKE_HRESULT_ENTRY(DV_E_LINDEX), + MAKE_HRESULT_ENTRY(DV_E_NOIVIEWOBJECT), + MAKE_HRESULT_ENTRY(DV_E_STATDATA), + MAKE_HRESULT_ENTRY(DV_E_STGMEDIUM), + MAKE_HRESULT_ENTRY(DV_E_TYMED), + MAKE_HRESULT_ENTRY(INPLACE_E_NOTOOLSPACE), + MAKE_HRESULT_ENTRY(INPLACE_E_NOTUNDOABLE), + MAKE_HRESULT_ENTRY(MEM_E_INVALID_LINK), + MAKE_HRESULT_ENTRY(MEM_E_INVALID_ROOT), + MAKE_HRESULT_ENTRY(MEM_E_INVALID_SIZE), + MAKE_HRESULT_ENTRY(MK_E_CANTOPENFILE), + MAKE_HRESULT_ENTRY(MK_E_CONNECTMANUALLY), + MAKE_HRESULT_ENTRY(MK_E_ENUMERATION_FAILED), + MAKE_HRESULT_ENTRY(MK_E_EXCEEDEDDEADLINE), + MAKE_HRESULT_ENTRY(MK_E_INTERMEDIATEINTERFACENOTSUPPORTED), + MAKE_HRESULT_ENTRY(MK_E_INVALIDEXTENSION), + MAKE_HRESULT_ENTRY(MK_E_MUSTBOTHERUSER), + MAKE_HRESULT_ENTRY(MK_E_NEEDGENERIC), + MAKE_HRESULT_ENTRY(MK_E_NO_NORMALIZED), + MAKE_HRESULT_ENTRY(MK_E_NOINVERSE), + MAKE_HRESULT_ENTRY(MK_E_NOOBJECT), + MAKE_HRESULT_ENTRY(MK_E_NOPREFIX), + MAKE_HRESULT_ENTRY(MK_E_NOSTORAGE), + MAKE_HRESULT_ENTRY(MK_E_NOTBINDABLE), + MAKE_HRESULT_ENTRY(MK_E_NOTBOUND), + MAKE_HRESULT_ENTRY(MK_E_SYNTAX), + MAKE_HRESULT_ENTRY(MK_E_UNAVAILABLE), + MAKE_HRESULT_ENTRY(OLE_E_ADVF), + MAKE_HRESULT_ENTRY(OLE_E_ADVISENOTSUPPORTED), + MAKE_HRESULT_ENTRY(OLE_E_BLANK), + MAKE_HRESULT_ENTRY(OLE_E_CANT_BINDTOSOURCE), + MAKE_HRESULT_ENTRY(OLE_E_CANT_GETMONIKER), + MAKE_HRESULT_ENTRY(OLE_E_CANTCONVERT), + MAKE_HRESULT_ENTRY(OLE_E_CLASSDIFF), + MAKE_HRESULT_ENTRY(OLE_E_ENUM_NOMORE), + MAKE_HRESULT_ENTRY(OLE_E_INVALIDHWND), + MAKE_HRESULT_ENTRY(OLE_E_INVALIDRECT), + MAKE_HRESULT_ENTRY(OLE_E_NOCACHE), + MAKE_HRESULT_ENTRY(OLE_E_NOCONNECTION), + MAKE_HRESULT_ENTRY(OLE_E_NOSTORAGE), + MAKE_HRESULT_ENTRY(OLE_E_NOT_INPLACEACTIVE), + MAKE_HRESULT_ENTRY(OLE_E_NOTRUNNING), + MAKE_HRESULT_ENTRY(OLE_E_OLEVERB), + MAKE_HRESULT_ENTRY(OLE_E_PROMPTSAVECANCELLED), + MAKE_HRESULT_ENTRY(OLE_E_STATIC), + MAKE_HRESULT_ENTRY(OLE_E_WRONGCOMPOBJ), + MAKE_HRESULT_ENTRY(OLEOBJ_E_INVALIDVERB), + MAKE_HRESULT_ENTRY(OLEOBJ_E_NOVERBS), + MAKE_HRESULT_ENTRY(REGDB_E_CLASSNOTREG), + MAKE_HRESULT_ENTRY(REGDB_E_IIDNOTREG), + MAKE_HRESULT_ENTRY(REGDB_E_INVALIDVALUE), + MAKE_HRESULT_ENTRY(REGDB_E_KEYMISSING), + MAKE_HRESULT_ENTRY(REGDB_E_READREGDB), + MAKE_HRESULT_ENTRY(REGDB_E_WRITEREGDB), + MAKE_HRESULT_ENTRY(RPC_E_ATTEMPTED_MULTITHREAD), + MAKE_HRESULT_ENTRY(RPC_E_CALL_CANCELED), + MAKE_HRESULT_ENTRY(RPC_E_CALL_REJECTED), + MAKE_HRESULT_ENTRY(RPC_E_CANTCALLOUT_AGAIN), + MAKE_HRESULT_ENTRY(RPC_E_CANTCALLOUT_INASYNCCALL), + MAKE_HRESULT_ENTRY(RPC_E_CANTCALLOUT_INEXTERNALCALL), + MAKE_HRESULT_ENTRY(RPC_E_CANTCALLOUT_ININPUTSYNCCALL), + MAKE_HRESULT_ENTRY(RPC_E_CANTPOST_INSENDCALL), + MAKE_HRESULT_ENTRY(RPC_E_CANTTRANSMIT_CALL), + MAKE_HRESULT_ENTRY(RPC_E_CHANGED_MODE), + MAKE_HRESULT_ENTRY(RPC_E_CLIENT_CANTMARSHAL_DATA), + MAKE_HRESULT_ENTRY(RPC_E_CLIENT_CANTUNMARSHAL_DATA), + MAKE_HRESULT_ENTRY(RPC_E_CLIENT_DIED), + MAKE_HRESULT_ENTRY(RPC_E_CONNECTION_TERMINATED), + MAKE_HRESULT_ENTRY(RPC_E_DISCONNECTED), + MAKE_HRESULT_ENTRY(RPC_E_FAULT), + MAKE_HRESULT_ENTRY(RPC_E_INVALID_CALLDATA), + MAKE_HRESULT_ENTRY(RPC_E_INVALID_DATA), + MAKE_HRESULT_ENTRY(RPC_E_INVALID_DATAPACKET), + MAKE_HRESULT_ENTRY(RPC_E_INVALID_PARAMETER), + MAKE_HRESULT_ENTRY(RPC_E_INVALIDMETHOD), + MAKE_HRESULT_ENTRY(RPC_E_NOT_REGISTERED), + MAKE_HRESULT_ENTRY(RPC_E_OUT_OF_RESOURCES), + MAKE_HRESULT_ENTRY(RPC_E_RETRY), + MAKE_HRESULT_ENTRY(RPC_E_SERVER_CANTMARSHAL_DATA), + MAKE_HRESULT_ENTRY(RPC_E_SERVER_CANTUNMARSHAL_DATA), + MAKE_HRESULT_ENTRY(RPC_E_SERVER_DIED), + MAKE_HRESULT_ENTRY(RPC_E_SERVER_DIED_DNE), + MAKE_HRESULT_ENTRY(RPC_E_SERVERCALL_REJECTED), + MAKE_HRESULT_ENTRY(RPC_E_SERVERCALL_RETRYLATER), + MAKE_HRESULT_ENTRY(RPC_E_SERVERFAULT), + MAKE_HRESULT_ENTRY(RPC_E_SYS_CALL_FAILED), + MAKE_HRESULT_ENTRY(RPC_E_THREAD_NOT_INIT), + MAKE_HRESULT_ENTRY(RPC_E_UNEXPECTED), + MAKE_HRESULT_ENTRY(RPC_E_WRONG_THREAD), + MAKE_HRESULT_ENTRY(STG_E_ABNORMALAPIEXIT), + MAKE_HRESULT_ENTRY(STG_E_ACCESSDENIED), + MAKE_HRESULT_ENTRY(STG_E_CANTSAVE), + MAKE_HRESULT_ENTRY(STG_E_DISKISWRITEPROTECTED), + MAKE_HRESULT_ENTRY(STG_E_EXTANTMARSHALLINGS), + MAKE_HRESULT_ENTRY(STG_E_FILEALREADYEXISTS), + MAKE_HRESULT_ENTRY(STG_E_FILENOTFOUND), + MAKE_HRESULT_ENTRY(STG_E_INSUFFICIENTMEMORY), + MAKE_HRESULT_ENTRY(STG_E_INUSE), + MAKE_HRESULT_ENTRY(STG_E_INVALIDFLAG), + MAKE_HRESULT_ENTRY(STG_E_INVALIDFUNCTION), + MAKE_HRESULT_ENTRY(STG_E_INVALIDHANDLE), + MAKE_HRESULT_ENTRY(STG_E_INVALIDHEADER), + MAKE_HRESULT_ENTRY(STG_E_INVALIDNAME), + MAKE_HRESULT_ENTRY(STG_E_INVALIDPARAMETER), + MAKE_HRESULT_ENTRY(STG_E_INVALIDPOINTER), + MAKE_HRESULT_ENTRY(STG_E_LOCKVIOLATION), + MAKE_HRESULT_ENTRY(STG_E_MEDIUMFULL), + MAKE_HRESULT_ENTRY(STG_E_NOMOREFILES), + MAKE_HRESULT_ENTRY(STG_E_NOTCURRENT), + MAKE_HRESULT_ENTRY(STG_E_NOTFILEBASEDSTORAGE), + MAKE_HRESULT_ENTRY(STG_E_OLDDLL), + MAKE_HRESULT_ENTRY(STG_E_OLDFORMAT), + MAKE_HRESULT_ENTRY(STG_E_PATHNOTFOUND), + MAKE_HRESULT_ENTRY(STG_E_READFAULT), + MAKE_HRESULT_ENTRY(STG_E_REVERTED), + MAKE_HRESULT_ENTRY(STG_E_SEEKERROR), + MAKE_HRESULT_ENTRY(STG_E_SHAREREQUIRED), + MAKE_HRESULT_ENTRY(STG_E_SHAREVIOLATION), + MAKE_HRESULT_ENTRY(STG_E_TOOMANYOPENFILES), + MAKE_HRESULT_ENTRY(STG_E_UNIMPLEMENTEDFUNCTION), + MAKE_HRESULT_ENTRY(STG_E_UNKNOWN), + MAKE_HRESULT_ENTRY(STG_E_WRITEFAULT), + MAKE_HRESULT_ENTRY(TYPE_E_AMBIGUOUSNAME), + MAKE_HRESULT_ENTRY(TYPE_E_BADMODULEKIND), + MAKE_HRESULT_ENTRY(TYPE_E_BUFFERTOOSMALL), + MAKE_HRESULT_ENTRY(TYPE_E_CANTCREATETMPFILE), + MAKE_HRESULT_ENTRY(TYPE_E_CANTLOADLIBRARY), + MAKE_HRESULT_ENTRY(TYPE_E_CIRCULARTYPE), + MAKE_HRESULT_ENTRY(TYPE_E_DLLFUNCTIONNOTFOUND), + MAKE_HRESULT_ENTRY(TYPE_E_DUPLICATEID), + MAKE_HRESULT_ENTRY(TYPE_E_ELEMENTNOTFOUND), + MAKE_HRESULT_ENTRY(TYPE_E_INCONSISTENTPROPFUNCS), + MAKE_HRESULT_ENTRY(TYPE_E_INVALIDSTATE), + MAKE_HRESULT_ENTRY(TYPE_E_INVDATAREAD), + MAKE_HRESULT_ENTRY(TYPE_E_IOERROR), + MAKE_HRESULT_ENTRY(TYPE_E_LIBNOTREGISTERED), + MAKE_HRESULT_ENTRY(TYPE_E_NAMECONFLICT), + MAKE_HRESULT_ENTRY(TYPE_E_OUTOFBOUNDS), + MAKE_HRESULT_ENTRY(TYPE_E_QUALIFIEDNAMEDISALLOWED), + MAKE_HRESULT_ENTRY(TYPE_E_REGISTRYACCESS), + MAKE_HRESULT_ENTRY(TYPE_E_SIZETOOBIG), + MAKE_HRESULT_ENTRY(TYPE_E_TYPEMISMATCH), + MAKE_HRESULT_ENTRY(TYPE_E_UNDEFINEDTYPE), + MAKE_HRESULT_ENTRY(TYPE_E_UNKNOWNLCID), + MAKE_HRESULT_ENTRY(TYPE_E_UNSUPFORMAT), + MAKE_HRESULT_ENTRY(TYPE_E_WRONGTYPEKIND), + MAKE_HRESULT_ENTRY(VIEW_E_DRAW), + +#if NOT_AVAILABLE + MAKE_HRESULT_ENTRY(CONNECT_E_NOCONNECTION), + MAKE_HRESULT_ENTRY(CONNECT_E_ADVISELIMIT), + MAKE_HRESULT_ENTRY(CONNECT_E_CANNOTCONNECT), + MAKE_HRESULT_ENTRY(CONNECT_E_OVERRIDDEN), +#endif + +#ifndef NO_PYCOM_IPROVIDECLASSINFO + MAKE_HRESULT_ENTRY(CLASS_E_NOTLICENSED), + MAKE_HRESULT_ENTRY(CLASS_E_NOAGGREGATION), + MAKE_HRESULT_ENTRY(CLASS_E_CLASSNOTAVAILABLE), +#endif // NO_PYCOM_IPROVIDECLASSINFO + +#ifndef MS_WINCE // ?? +#if AVAILABLE + MAKE_HRESULT_ENTRY(CTL_E_ILLEGALFUNCTIONCALL ), + MAKE_HRESULT_ENTRY(CTL_E_OVERFLOW ), + MAKE_HRESULT_ENTRY(CTL_E_OUTOFMEMORY ), + MAKE_HRESULT_ENTRY(CTL_E_DIVISIONBYZERO ), + MAKE_HRESULT_ENTRY(CTL_E_OUTOFSTRINGSPACE ), + MAKE_HRESULT_ENTRY(CTL_E_OUTOFSTACKSPACE ), + MAKE_HRESULT_ENTRY(CTL_E_BADFILENAMEORNUMBER ), + MAKE_HRESULT_ENTRY(CTL_E_FILENOTFOUND ), + MAKE_HRESULT_ENTRY(CTL_E_BADFILEMODE ), + MAKE_HRESULT_ENTRY(CTL_E_FILEALREADYOPEN ), + MAKE_HRESULT_ENTRY(CTL_E_DEVICEIOERROR ), + MAKE_HRESULT_ENTRY(CTL_E_FILEALREADYEXISTS ), + MAKE_HRESULT_ENTRY(CTL_E_BADRECORDLENGTH ), + MAKE_HRESULT_ENTRY(CTL_E_DISKFULL ), + MAKE_HRESULT_ENTRY(CTL_E_BADRECORDNUMBER ), + MAKE_HRESULT_ENTRY(CTL_E_BADFILENAME ), + MAKE_HRESULT_ENTRY(CTL_E_TOOMANYFILES ), + MAKE_HRESULT_ENTRY(CTL_E_DEVICEUNAVAILABLE ), + MAKE_HRESULT_ENTRY(CTL_E_PERMISSIONDENIED ), + MAKE_HRESULT_ENTRY(CTL_E_DISKNOTREADY ), + MAKE_HRESULT_ENTRY(CTL_E_PATHFILEACCESSERROR ), + MAKE_HRESULT_ENTRY(CTL_E_PATHNOTFOUND ), + MAKE_HRESULT_ENTRY(CTL_E_INVALIDPATTERNSTRING ), + MAKE_HRESULT_ENTRY(CTL_E_INVALIDUSEOFNULL ), + MAKE_HRESULT_ENTRY(CTL_E_INVALIDFILEFORMAT ), + MAKE_HRESULT_ENTRY(CTL_E_INVALIDPROPERTYVALUE ), + MAKE_HRESULT_ENTRY(CTL_E_INVALIDPROPERTYARRAYINDEX), + MAKE_HRESULT_ENTRY(CTL_E_SETNOTSUPPORTEDATRUNTIME ), + MAKE_HRESULT_ENTRY(CTL_E_SETNOTSUPPORTED ), + MAKE_HRESULT_ENTRY(CTL_E_NEEDPROPERTYARRAYINDEX ), + MAKE_HRESULT_ENTRY(CTL_E_SETNOTPERMITTED ), + MAKE_HRESULT_ENTRY(CTL_E_GETNOTSUPPORTEDATRUNTIME ), + MAKE_HRESULT_ENTRY(CTL_E_GETNOTSUPPORTED ), + MAKE_HRESULT_ENTRY(CTL_E_PROPERTYNOTFOUND ), + MAKE_HRESULT_ENTRY(CTL_E_INVALIDCLIPBOARDFORMAT ), + MAKE_HRESULT_ENTRY(CTL_E_INVALIDPICTURE ), + MAKE_HRESULT_ENTRY(CTL_E_PRINTERERROR ), + MAKE_HRESULT_ENTRY(CTL_E_CANTSAVEFILETOTEMP ), + MAKE_HRESULT_ENTRY(CTL_E_SEARCHTEXTNOTFOUND ), + MAKE_HRESULT_ENTRY(CTL_E_REPLACEMENTSTOOLONG ), +#endif +#endif // MS_WINCE + }; + #undef MAKE_HRESULT_ENTRY + + +#ifndef _countof +#define _countof(array) (sizeof(array)/sizeof(array[0])) +#endif +void GetScodeString(HRESULT hr, LPTSTR buf, int bufSize) +{ + // first ask the OS to give it to us.. + // ### should we get the Unicode version instead? + int numCopied = ::FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, NULL, hr, 0, buf, bufSize, NULL ); + if (numCopied>0) { + if (numCopied2 && (buf[numCopied-2]=='\n'||buf[numCopied-2]=='\r')) + buf[numCopied-2] = '\0'; + } + return; + } + + // else look for it in the table + for (unsigned int i = 0; i < _countof(hrNameTable); i++) + { + if (hr == hrNameTable[i].hr) { + strncpy(buf, hrNameTable[i].lpszName, bufSize); + return; + } + } + // not found - make one up + sprintf(buf, ("OLE error 0x%08lx"), hr); +} + + + + +void +COMError(HRESULT hr) +{ + TCHAR buf[512]; + GetScodeString(hr, buf, sizeof(buf)/sizeof(buf[0])); + /* + PROBLEM buf + ERROR; + */ + SEXP e; + PROTECT(e = allocVector(LANGSXP, 3)); + SETCAR(e, Rf_install("COMStop")); + SETCAR(CDR(e), mkString(buf)); + SETCAR(CDR(CDR(e)), ScalarInteger(hr)); + Rf_eval(e, R_GlobalEnv); + UNPROTECT(1); /* Won't come back to here. */ +} + + + + +/* 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, " %lX \n", 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_createCOMErrorCodes() +{ + SEXP ans, names; + int n; + n = _countof(hrNameTable); + PROTECT(ans = allocVector(REALSXP, n)); + PROTECT(names = allocVector(STRSXP, n)); + for (int i = 0; i < n; i++) + { + REAL(ans)[i] = (double) hrNameTable[i].hr; + SET_STRING_ELT(names, i, COPY_TO_USER_STRING(hrNameTable[i].lpszName)); + } + + SET_NAMES(ans, names); + UNPROTECT(2); + return(ans); +} diff --git a/src/RCOMObject.cpp b/src/RCOMObject.cpp index fc1e145..cdd8fbf 100644 --- a/src/RCOMObject.cpp +++ b/src/RCOMObject.cpp @@ -1,467 +1,467 @@ -#include "RCOMObject.h" -#include - -#undef ERROR - -extern "C" { -#include -} - -bool isCOMError(SEXP obj); -bool isClass(SEXP obj, const char *name); -HRESULT processCOMError(SEXP obj, EXCEPINFO *excep, UINT *argNum); -static SEXP callQueryInterfaceMethod(SEXP obj, char *guid); - - -HRESULT __stdcall -RCOMObject::QueryInterface(const IID& iid, void** ppv) -{ - HRESULT hr; - - LPOLESTR ostr; - char *gname; - StringFromCLSID(iid, &ostr); - gname = FromBstr(ostr); - -#ifdef RDCOM_VERBOSE - errorLog("[RCOMObject::QueryInterface] %s\n", gname); -#endif - -#if 0 - hr = this->unknown->QueryInterface(iid, ppv); - if(hr == S_OK) { - SysFreeString(ostr); - return(hr); - } -#endif - - - if(iid == IID_IUnknown) { - *ppv = static_cast(this); - hr = S_OK; - } else if(iid == IID_IDispatch) { - *ppv = static_cast(this); - hr = S_OK; - } else { -#if 1 - /* Call the generic R function to see if it wants to respond. - It can query TRUE or FALSE or give an external pointer. - If it returns TRUE, we return this object. If it returns FALSE, - we return an error. And if it returns an external pointer, we - return that. It is up to the function to get that right!!!! - */ - SEXP ans = callQueryInterfaceMethod(this->obj, gname); - if(TYPEOF(ans) == LGLSXP) { - hr = LOGICAL(ans)[0] ? S_OK : E_NOINTERFACE; - if(hr == S_OK) - *ppv = static_cast(this); - else - *ppv = NULL; - } else if(TYPEOF(ans) == EXTPTRSXP) { - /* If it is an external ptr. */ - *ppv = R_ExternalPtrAddr(ans); - hr = S_OK; - } else { - *ppv = NULL; - hr = E_NOINTERFACE; -#ifdef RDCOM_VERBOSE - errorLog("iid not handled in RCOMObject::QueryInterface %s\n", gname); -#endif - } - -#else - *ppv = NULL; - hr = E_NOINTERFACE; - /* *ppv = static_cast(this); */ -#endif - } - - if(*ppv) - reinterpret_cast(*ppv)->AddRef(); - -#ifdef RDCOM_VERBOSE - errorLog("[end RCOMObject::QueryInterface]\n"); -#endif - SysFreeString(ostr); - - return hr; -} - - -/* - Call the QueryInterface generic function. -*/ -static SEXP -callQueryInterfaceMethod(SEXP obj, char *guid) -{ - SEXP e, ans = R_NilValue; - int errorOccurred = 0; - - PROTECT(e = allocVector(LANGSXP, 3)); - SETCAR(e, Rf_install("QueryInterface")); - SETCAR(CDR(e), obj); - SETCAR(CDR(CDR(e)), mkString(guid)); - - ans = R_tryEval(e, R_GlobalEnv, &errorOccurred); - - UNPROTECT(1); - if(errorOccurred) { - return(R_NilValue); - } - - return(ans); -} - - -// Need to handle case where cNames > 1 - -HRESULT __stdcall -RCOMEnvironmentObject::GetIDsOfNames(REFIID refId, LPOLESTR *name, UINT cNames, LCID local, DISPID *id) -{ - SEXP names; - HRESULT hr; - -#ifdef RDCOM_VERBOSE - errorLog("[RCOMEnvironment::GetIDsOfNames] %p\n", this->obj); -#endif - - /* Loop over the names of the elements in the function and find the index of the - one that matches the method. */ - names = GET_NAMES(this->obj); - - hr = lookupRName(names, name, id); - - return(hr); - /*XXX Now look for properties. */ -} - -HRESULT -RCOMObject::lookupRName(SEXP names, LPOLESTR *name, DISPID *id) -{ - char str[1000]; - memset(str, '\0', sizeof(str)/sizeof(str[0])); - WideCharToMultiByte(CP_ACP, 0, *name, -1, str, sizeof(str)/sizeof(str[0]), NULL, NULL); - return(lookupRName(names, str, id)); -} - -HRESULT -RCOMObject::lookupRName(SEXP names, const char * const str, DISPID *id) -{ - int i, n; - - n = Rf_length(names); - -#ifdef RDCOM_VERBOSE - errorLog("Looking for method '%s'\n", str); -#endif - - for(i = 0; i < n; i++) { - if(strcmp(str, CHAR(STRING_ELT(names, i))) == 0) { - *id = i; - break; - } - } - -#ifdef RDCOM_VERBOSE - if(i == n) { - errorLog("Couldn't find method %s\n", str); - } else { - errorLog("Method id for %s = %ld\n", str, *id); - } -#endif - - return(i < n ? S_OK : S_FALSE); -} - -HRESULT __stdcall -RCOMEnvironmentObject::Invoke(DISPID id, REFIID refId, LCID locale, WORD method, DISPPARAMS *parms, - VARIANT *var, EXCEPINFO *excep, UINT *argNumErr) -{ - SEXP func; - -#ifdef RDCOM_VERBOSE - errorLog("Method id %ld, method = %d", id, method); -#endif - func = VECTOR_ELT(this->obj, id); - - return(callRFunc(func, id, refId, locale, method, parms, var, excep, argNumErr)); -} - -int -RCOMObject::getCallLength(DISPPARAMS *parms) -{ - return(parms->cArgs + 1); -} - -SEXP -RCOMObject::getCallExpression(SEXP func, DISPPARAMS *parms, DISPID id, WORD method, SEXP *ptr) -{ - SEXP e; - PROTECT(e = allocVector(LANGSXP, getCallLength(parms))); - SETCAR(e, func); - *ptr = CDR(e); - UNPROTECT(1); - return(e); -} - -HRESULT __stdcall -RCOMObject::callRFunc(SEXP func, DISPID id, REFIID refId, LCID locale, WORD method, DISPPARAMS *parms, - VARIANT *var, EXCEPINFO *excep, UINT *argNumErr) -{ - SEXP e, ptr, val; - int errorOccurred, i, nargs; - HRESULT hr = S_OK; - - PROTECT(e = getCallExpression(func, parms, id, method, &ptr)); - nargs = parms->cArgs; - - for(i = 0; i < nargs; i++) { - SETCAR(ptr, convertToR(parms->rgvarg[i])); - ptr = CDR(ptr); - } - - val = R_tryEval(e, R_GlobalEnv, &errorOccurred); - if(errorOccurred) { - // Fill in excep - UNPROTECT(1); - return(S_FALSE); - } - PROTECT(val); - - if(var) - hr = convertToCOM(val, var); - - if(FAILED(hr)) { - //XXX Fill in excep. - return(S_FALSE); - } - - UNPROTECT(2); - - return(S_OK); -} - - -HRESULT __stdcall -RCOMFunctionsObject::GetIDsOfNames(REFIID refId, LPOLESTR *name, UINT huh, LCID locale, DISPID *id) -{ - int which; - which = lookupRName(this->obj, name, id); - if(which < 0) { - return(S_FALSE); - } - - *id = which; - - return(S_OK); -} - - -HRESULT __stdcall -RCOMFunctionsObject::Invoke(DISPID id, REFIID refId, LCID locale, WORD method, DISPPARAMS *parms, - VARIANT *var, EXCEPINFO *excep, UINT *argNumErr) -{ - const char *funName; - funName = CHAR(STRING_ELT(this->obj, id)); - - return(callRFunc(Rf_install(funName), id, refId, locale, method, parms, var, excep, argNumErr)); -} - - -/* Add an extra one. */ -int -RCOMS4Object::getCallLength(DISPPARAMS *params) -{ - return(RCOMObject::getCallLength(params) + 1); -} - -SEXP -RCOMS4Object::getCallExpression(SEXP func, DISPPARAMS *parms, DISPID id, WORD method, SEXP *ptr) -{ - SEXP e; - PROTECT(e = RCOMFunctionsObject::getCallExpression(func, parms, id, method, ptr)); - SETCAR(*ptr, Sthis); - *ptr = CDR(*ptr); - UNPROTECT(1); - return(e); -} - - -SEXP -asRStringVector(LPOLESTR *name, UINT cNames) -{ - SEXP tmp; - UINT i; - char str[1000]; - PROTECT(tmp = allocVector(STRSXP, cNames)); - for(i = 0; i < cNames; i++) { - memset(str, '\0', sizeof(str)/sizeof(str[0])); - WideCharToMultiByte(CP_ACP, 0, name[i], -1, str, sizeof(str)/sizeof(str[0]), NULL, NULL); - SET_STRING_ELT(tmp, i, COPY_TO_USER_STRING(str)); - } - UNPROTECT(1); - return(tmp); -} - -HRESULT __stdcall -RCOMSObject::GetIDsOfNames(REFIID refId, LPOLESTR *name, UINT cNames, LCID locale, DISPID *id) -{ - SEXP e, val; - int errorOccurred; - UINT i; - - PROTECT(e = allocVector(LANGSXP, 2)); - SETCAR(e, VECTOR_ELT(this->obj, IDS_OF_NAMES)); - SETCAR(CDR(e), asRStringVector(name, cNames)); - - PROTECT(val = R_tryEval(e, R_GlobalEnv, &errorOccurred)); - if(!errorOccurred && val != R_NilValue) { - //XXX Must be an integer. Need to coerce - for(i = 0; i < cNames; i++) { - id[i] = INTEGER(val)[i]; - } - } - UNPROTECT(2); - - return(errorOccurred ? S_FALSE : S_OK); -} - -#if 0 -/* - Call the invoke function for this instance and pass it - the method id and the arguments from COM. -*/ -SEXP -RCOMSObject::getCallExpression(SEXP func, DISPPARAMS *parms, DISPID id, WORD method, SEXP *ptr) -{ - SEXP e, tmp; - PROTECT(e = allocVector(LANGSXP, getCallLength(parms))); - SETCAR(e, func); - SETCAR(CDR(e), tmp = allocVector(INTSXP, 1)); - INTEGER(tmp)[0] = id; - SETCAR(CDR(CDR(e)), tmp = allocVector(INTSXP, 1)); - INTEGER(tmp)[0] = method; - *ptr = CDR(CDR(CDR(e))); - UNPROTECT(1); - return(e); -} -#endif - -HRESULT __stdcall -RCOMSObject::Invoke(DISPID id, REFIID refId, LCID locale, WORD method, DISPPARAMS *parms, - VARIANT *var, EXCEPINFO *excep, UINT *argNumErr) -{ - int errorOccurred; - UINT i; - SEXP e, ptr, val, tmp; - -#if defined(RDCOM_VERBOSE) && RDCOM_VERBOSE - errorLog("About to call RCOMSObject::Invoke\n"); -#endif - - PROTECT(e = ptr = allocVector(LANGSXP, 5)); - SETCAR(e, VECTOR_ELT(obj, INVOKE)); - - ptr = CDR(e); - SETCAR(ptr, tmp = allocVector(INTSXP, 1)); - INTEGER(tmp)[0] = id; - - ptr = CDR(ptr); - SETCAR(ptr, tmp = allocVector(LGLSXP, 4)); - LOGICAL(tmp)[0] = (method & INVOKE_FUNC) ? TRUE : FALSE; - LOGICAL(tmp)[1] = (method & INVOKE_PROPERTYGET) ? TRUE : FALSE; - LOGICAL(tmp)[2] = (method & INVOKE_PROPERTYPUT) ? TRUE : FALSE; - LOGICAL(tmp)[3] = (method & INVOKE_PROPERTYPUTREF) ? TRUE : FALSE; - - ptr = CDR(ptr); - if(parms->cArgs > 0) { - PROTECT(tmp = allocVector(VECSXP, parms->cArgs)); - for(i = 0 ; i < parms->cArgs; i++) { - SET_VECTOR_ELT(tmp, i, convertToR(parms->rgvarg[i])); - } - SETCAR(ptr, tmp); - UNPROTECT(1); - } else - SETCAR(ptr, R_NilValue); - - - ptr = CDR(ptr); - if(parms->cNamedArgs) { - PROTECT(tmp = allocVector(INTSXP, parms->cNamedArgs)); - for(i = 0; i < parms->cNamedArgs ; i++) { - INTEGER(tmp)[i] = parms->rgdispidNamedArgs[i]; - } - SETCAR(ptr, tmp); - UNPROTECT(1); - } else - SETCAR(ptr, R_NilValue); - - - val = R_tryEval(e, R_GlobalEnv, &errorOccurred); - - if(errorOccurred) { - UNPROTECT(1); -#if defined(RDCOM_VERBOSE) && RDCOM_VERBOSE - errorLog(" failed\n"); -#endif - return(S_FALSE); - } - PROTECT(val); - - if(isCOMError(val)) { - HRESULT status = processCOMError(val, excep, argNumErr); - UNPROTECT(2); - return(status); - } - - convertToCOM(val, var); - UNPROTECT(2); - - return(S_OK); -} - -HRESULT -processCOMError(SEXP obj, EXCEPINFO *excep, UINT *argNum) -{ - HRESULT status; - - if(isClass(obj, "COMReturnValue")) { - //XXX status = (HRESULT) REAL(VECTOR_ELT(obj, 0))[0]; - status = DISP_E_MEMBERNOTFOUND; - } - - return(status); -} - -bool -isCOMError(SEXP obj) -{ - return(isClass(obj, "COMError")); -} - -bool -isClass(SEXP obj, const char *name) -{ - SEXP klass; - klass = GET_CLASS(obj); - for(int i = 0; i < Rf_length(klass); i++) { - if(strcmp(name, CHAR(STRING_ELT(klass, i))) == 0) - return(TRUE); - } - - return(FALSE); -} - - -void -RCOMSObject::destroy() -{ - if(Rf_length(obj) < 3 || VECTOR_ELT(obj, DESTRUCTOR) == R_NilValue) - return; - - SEXP e; - PROTECT(e = allocVector(LANGSXP, 1)); - SETCAR(e, VECTOR_ELT(obj, DESTRUCTOR)); - R_tryEval(e, R_GlobalEnv, NULL); - UNPROTECT(1); -} +#include "RCOMObject.h" +#include + +#undef ERROR + +extern "C" { +#include +} + +bool isCOMError(SEXP obj); +bool isClass(SEXP obj, const char *name); +HRESULT processCOMError(SEXP obj, EXCEPINFO *excep, UINT *argNum); +static SEXP callQueryInterfaceMethod(SEXP obj, char *guid); + + +HRESULT __stdcall +RCOMObject::QueryInterface(const IID& iid, void** ppv) +{ + HRESULT hr; + + LPOLESTR ostr; + char *gname; + StringFromCLSID(iid, &ostr); + gname = FromBstr(ostr); + +#ifdef RDCOM_VERBOSE + errorLog("[RCOMObject::QueryInterface] %s\n", gname); +#endif + +#if 0 + hr = this->unknown->QueryInterface(iid, ppv); + if(hr == S_OK) { + SysFreeString(ostr); + return(hr); + } +#endif + + + if(iid == IID_IUnknown) { + *ppv = static_cast(this); + hr = S_OK; + } else if(iid == IID_IDispatch) { + *ppv = static_cast(this); + hr = S_OK; + } else { +#if 1 + /* Call the generic R function to see if it wants to respond. + It can query TRUE or FALSE or give an external pointer. + If it returns TRUE, we return this object. If it returns FALSE, + we return an error. And if it returns an external pointer, we + return that. It is up to the function to get that right!!!! + */ + SEXP ans = callQueryInterfaceMethod(this->obj, gname); + if(TYPEOF(ans) == LGLSXP) { + hr = LOGICAL(ans)[0] ? S_OK : E_NOINTERFACE; + if(hr == S_OK) + *ppv = static_cast(this); + else + *ppv = NULL; + } else if(TYPEOF(ans) == EXTPTRSXP) { + /* If it is an external ptr. */ + *ppv = R_ExternalPtrAddr(ans); + hr = S_OK; + } else { + *ppv = NULL; + hr = E_NOINTERFACE; +#ifdef RDCOM_VERBOSE + errorLog("iid not handled in RCOMObject::QueryInterface %s\n", gname); +#endif + } + +#else + *ppv = NULL; + hr = E_NOINTERFACE; + /* *ppv = static_cast(this); */ +#endif + } + + if(*ppv) + reinterpret_cast(*ppv)->AddRef(); + +#ifdef RDCOM_VERBOSE + errorLog("[end RCOMObject::QueryInterface]\n"); +#endif + SysFreeString(ostr); + + return hr; +} + + +/* + Call the QueryInterface generic function. +*/ +static SEXP +callQueryInterfaceMethod(SEXP obj, char *guid) +{ + SEXP e, ans = R_NilValue; + int errorOccurred = 0; + + PROTECT(e = allocVector(LANGSXP, 3)); + SETCAR(e, Rf_install("QueryInterface")); + SETCAR(CDR(e), obj); + SETCAR(CDR(CDR(e)), mkString(guid)); + + ans = R_tryEval(e, R_GlobalEnv, &errorOccurred); + + UNPROTECT(1); + if(errorOccurred) { + return(R_NilValue); + } + + return(ans); +} + + +// Need to handle case where cNames > 1 + +HRESULT __stdcall +RCOMEnvironmentObject::GetIDsOfNames(REFIID refId, LPOLESTR *name, UINT cNames, LCID local, DISPID *id) +{ + SEXP names; + HRESULT hr; + +#ifdef RDCOM_VERBOSE + errorLog("[RCOMEnvironment::GetIDsOfNames] %p\n", this->obj); +#endif + + /* Loop over the names of the elements in the function and find the index of the + one that matches the method. */ + names = GET_NAMES(this->obj); + + hr = lookupRName(names, name, id); + + return(hr); + /*XXX Now look for properties. */ +} + +HRESULT +RCOMObject::lookupRName(SEXP names, LPOLESTR *name, DISPID *id) +{ + char str[1000]; + memset(str, '\0', sizeof(str)/sizeof(str[0])); + WideCharToMultiByte(CP_ACP, 0, *name, -1, str, sizeof(str)/sizeof(str[0]), NULL, NULL); + return(lookupRName(names, str, id)); +} + +HRESULT +RCOMObject::lookupRName(SEXP names, const char * const str, DISPID *id) +{ + int i, n; + + n = Rf_length(names); + +#ifdef RDCOM_VERBOSE + errorLog("Looking for method '%s'\n", str); +#endif + + for(i = 0; i < n; i++) { + if(strcmp(str, CHAR(STRING_ELT(names, i))) == 0) { + *id = i; + break; + } + } + +#ifdef RDCOM_VERBOSE + if(i == n) { + errorLog("Couldn't find method %s\n", str); + } else { + errorLog("Method id for %s = %ld\n", str, *id); + } +#endif + + return(i < n ? S_OK : S_FALSE); +} + +HRESULT __stdcall +RCOMEnvironmentObject::Invoke(DISPID id, REFIID refId, LCID locale, WORD method, DISPPARAMS *parms, + VARIANT *var, EXCEPINFO *excep, UINT *argNumErr) +{ + SEXP func; + +#ifdef RDCOM_VERBOSE + errorLog("Method id %ld, method = %d", id, method); +#endif + func = VECTOR_ELT(this->obj, id); + + return(callRFunc(func, id, refId, locale, method, parms, var, excep, argNumErr)); +} + +int +RCOMObject::getCallLength(DISPPARAMS *parms) +{ + return(parms->cArgs + 1); +} + +SEXP +RCOMObject::getCallExpression(SEXP func, DISPPARAMS *parms, DISPID id, WORD method, SEXP *ptr) +{ + SEXP e; + PROTECT(e = allocVector(LANGSXP, getCallLength(parms))); + SETCAR(e, func); + *ptr = CDR(e); + UNPROTECT(1); + return(e); +} + +HRESULT __stdcall +RCOMObject::callRFunc(SEXP func, DISPID id, REFIID refId, LCID locale, WORD method, DISPPARAMS *parms, + VARIANT *var, EXCEPINFO *excep, UINT *argNumErr) +{ + SEXP e, ptr, val; + int errorOccurred, i, nargs; + HRESULT hr = S_OK; + + PROTECT(e = getCallExpression(func, parms, id, method, &ptr)); + nargs = parms->cArgs; + + for(i = 0; i < nargs; i++) { + SETCAR(ptr, convertToR(parms->rgvarg[i])); + ptr = CDR(ptr); + } + + val = R_tryEval(e, R_GlobalEnv, &errorOccurred); + if(errorOccurred) { + // Fill in excep + UNPROTECT(1); + return(S_FALSE); + } + PROTECT(val); + + if(var) + hr = convertToCOM(val, var); + + if(FAILED(hr)) { + //XXX Fill in excep. + return(S_FALSE); + } + + UNPROTECT(2); + + return(S_OK); +} + + +HRESULT __stdcall +RCOMFunctionsObject::GetIDsOfNames(REFIID refId, LPOLESTR *name, UINT huh, LCID locale, DISPID *id) +{ + int which; + which = lookupRName(this->obj, name, id); + if(which < 0) { + return(S_FALSE); + } + + *id = which; + + return(S_OK); +} + + +HRESULT __stdcall +RCOMFunctionsObject::Invoke(DISPID id, REFIID refId, LCID locale, WORD method, DISPPARAMS *parms, + VARIANT *var, EXCEPINFO *excep, UINT *argNumErr) +{ + const char *funName; + funName = CHAR(STRING_ELT(this->obj, id)); + + return(callRFunc(Rf_install(funName), id, refId, locale, method, parms, var, excep, argNumErr)); +} + + +/* Add an extra one. */ +int +RCOMS4Object::getCallLength(DISPPARAMS *params) +{ + return(RCOMObject::getCallLength(params) + 1); +} + +SEXP +RCOMS4Object::getCallExpression(SEXP func, DISPPARAMS *parms, DISPID id, WORD method, SEXP *ptr) +{ + SEXP e; + PROTECT(e = RCOMFunctionsObject::getCallExpression(func, parms, id, method, ptr)); + SETCAR(*ptr, Sthis); + *ptr = CDR(*ptr); + UNPROTECT(1); + return(e); +} + + +SEXP +asRStringVector(LPOLESTR *name, UINT cNames) +{ + SEXP tmp; + UINT i; + char str[1000]; + PROTECT(tmp = allocVector(STRSXP, cNames)); + for(i = 0; i < cNames; i++) { + memset(str, '\0', sizeof(str)/sizeof(str[0])); + WideCharToMultiByte(CP_ACP, 0, name[i], -1, str, sizeof(str)/sizeof(str[0]), NULL, NULL); + SET_STRING_ELT(tmp, i, COPY_TO_USER_STRING(str)); + } + UNPROTECT(1); + return(tmp); +} + +HRESULT __stdcall +RCOMSObject::GetIDsOfNames(REFIID refId, LPOLESTR *name, UINT cNames, LCID locale, DISPID *id) +{ + SEXP e, val; + int errorOccurred; + UINT i; + + PROTECT(e = allocVector(LANGSXP, 2)); + SETCAR(e, VECTOR_ELT(this->obj, IDS_OF_NAMES)); + SETCAR(CDR(e), asRStringVector(name, cNames)); + + PROTECT(val = R_tryEval(e, R_GlobalEnv, &errorOccurred)); + if(!errorOccurred && val != R_NilValue) { + //XXX Must be an integer. Need to coerce + for(i = 0; i < cNames; i++) { + id[i] = INTEGER(val)[i]; + } + } + UNPROTECT(2); + + return(errorOccurred ? S_FALSE : S_OK); +} + +#if 0 +/* + Call the invoke function for this instance and pass it + the method id and the arguments from COM. +*/ +SEXP +RCOMSObject::getCallExpression(SEXP func, DISPPARAMS *parms, DISPID id, WORD method, SEXP *ptr) +{ + SEXP e, tmp; + PROTECT(e = allocVector(LANGSXP, getCallLength(parms))); + SETCAR(e, func); + SETCAR(CDR(e), tmp = allocVector(INTSXP, 1)); + INTEGER(tmp)[0] = id; + SETCAR(CDR(CDR(e)), tmp = allocVector(INTSXP, 1)); + INTEGER(tmp)[0] = method; + *ptr = CDR(CDR(CDR(e))); + UNPROTECT(1); + return(e); +} +#endif + +HRESULT __stdcall +RCOMSObject::Invoke(DISPID id, REFIID refId, LCID locale, WORD method, DISPPARAMS *parms, + VARIANT *var, EXCEPINFO *excep, UINT *argNumErr) +{ + int errorOccurred; + UINT i; + SEXP e, ptr, val, tmp; + +#if defined(RDCOM_VERBOSE) && RDCOM_VERBOSE + errorLog("About to call RCOMSObject::Invoke\n"); +#endif + + PROTECT(e = ptr = allocVector(LANGSXP, 5)); + SETCAR(e, VECTOR_ELT(obj, INVOKE)); + + ptr = CDR(e); + SETCAR(ptr, tmp = allocVector(INTSXP, 1)); + INTEGER(tmp)[0] = id; + + ptr = CDR(ptr); + SETCAR(ptr, tmp = allocVector(LGLSXP, 4)); + LOGICAL(tmp)[0] = (method & INVOKE_FUNC) ? TRUE : FALSE; + LOGICAL(tmp)[1] = (method & INVOKE_PROPERTYGET) ? TRUE : FALSE; + LOGICAL(tmp)[2] = (method & INVOKE_PROPERTYPUT) ? TRUE : FALSE; + LOGICAL(tmp)[3] = (method & INVOKE_PROPERTYPUTREF) ? TRUE : FALSE; + + ptr = CDR(ptr); + if(parms->cArgs > 0) { + PROTECT(tmp = allocVector(VECSXP, parms->cArgs)); + for(i = 0 ; i < parms->cArgs; i++) { + SET_VECTOR_ELT(tmp, i, convertToR(parms->rgvarg[i])); + } + SETCAR(ptr, tmp); + UNPROTECT(1); + } else + SETCAR(ptr, R_NilValue); + + + ptr = CDR(ptr); + if(parms->cNamedArgs) { + PROTECT(tmp = allocVector(INTSXP, parms->cNamedArgs)); + for(i = 0; i < parms->cNamedArgs ; i++) { + INTEGER(tmp)[i] = parms->rgdispidNamedArgs[i]; + } + SETCAR(ptr, tmp); + UNPROTECT(1); + } else + SETCAR(ptr, R_NilValue); + + + val = R_tryEval(e, R_GlobalEnv, &errorOccurred); + + if(errorOccurred) { + UNPROTECT(1); +#if defined(RDCOM_VERBOSE) && RDCOM_VERBOSE + errorLog(" failed\n"); +#endif + return(S_FALSE); + } + PROTECT(val); + + if(isCOMError(val)) { + HRESULT status = processCOMError(val, excep, argNumErr); + UNPROTECT(2); + return(status); + } + + convertToCOM(val, var); + UNPROTECT(2); + + return(S_OK); +} + +HRESULT +processCOMError(SEXP obj, EXCEPINFO *excep, UINT *argNum) +{ + HRESULT status; + + if(isClass(obj, "COMReturnValue")) { + //XXX status = (HRESULT) REAL(VECTOR_ELT(obj, 0))[0]; + status = DISP_E_MEMBERNOTFOUND; + } + + return(status); +} + +bool +isCOMError(SEXP obj) +{ + return(isClass(obj, "COMError")); +} + +bool +isClass(SEXP obj, const char *name) +{ + SEXP klass; + klass = GET_CLASS(obj); + for(int i = 0; i < Rf_length(klass); i++) { + if(strcmp(name, CHAR(STRING_ELT(klass, i))) == 0) + return(TRUE); + } + + return(FALSE); +} + + +void +RCOMSObject::destroy() +{ + if(Rf_length(obj) < 3 || VECTOR_ELT(obj, DESTRUCTOR) == R_NilValue) + return; + + SEXP e; + PROTECT(e = allocVector(LANGSXP, 1)); + SETCAR(e, VECTOR_ELT(obj, DESTRUCTOR)); + R_tryEval(e, R_GlobalEnv, NULL); + UNPROTECT(1); +} diff --git a/src/connect.cpp b/src/connect.cpp index 0cf6d41..8bf2c38 100644 --- a/src/connect.cpp +++ b/src/connect.cpp @@ -1,573 +1,573 @@ -// # Package: RDCOMClient -// # Version: 0.93-0.2 -// # Title: R-DCOM Client -// # Author: Duncan Temple Lang -// # Maintainer: Duncan Temple Lang -// # Description: Provides dynamic client-side access to (D)COM applications from within R. -// # License: GPL-2 -// # Collate: classes.R COMLists.S COMError.R com.R debug.S zzz.R runTime.S -// # URL: http://www.omegahat.net/RDCOMClient, http://www.omegahat.net -// # http://www.omegahat.net/bugs -// Some parts of code by https://github.com/jototland/ jototland@gmail.com - -#ifndef _GNU_ -#include "stdafx.h" -#include -#else -#include -#include -#include -#include -#include -#ifndef V_UI4 -# define V_UI4(X) V_UNION((X), uintVal) -#endif - -#ifdef ERROR -#undef ERROR -#endif - -#endif - - -extern "C" { -#include "RUtils.h" -#include -#include -} - -#include /* for Rf_error and Rf_warning */ - -#ifdef R_PROBLEM_BUFSIZE -#undef R_PROBLEM_BUFSIZE -#endif -#ifdef PROBLEM -#undef PROBLEM -#endif - -#ifdef MESSAGE -#undef MESSAGE -#endif -#ifdef RECOVER -#undef RECOVER -#endif - - -#ifdef WARNING -#undef WARNING -#endif -#ifdef LOCAL_EVALUATOR -#undef LOCAL_EVALUATOR -#endif - -#ifdef NULL_ENTRY -#undef NULL_ENTRY -#endif - - -#ifdef WARN -#undef WARN -#endif -#ifdef ERROR -#undef ERROR -#endif - - -#define R_PROBLEM_BUFSIZE 4096 -/* Parentheses added for FC4 with gcc4 and -D_FORTIFY_SOURCE=2 */ -#define PROBLEM {char R_problem_buf[R_PROBLEM_BUFSIZE];(snprintf)(R_problem_buf, R_PROBLEM_BUFSIZE, -#define MESSAGE {char R_problem_buf[R_PROBLEM_BUFSIZE];(snprintf)(R_problem_buf, R_PROBLEM_BUFSIZE, -#define ERROR ),Rf_error(R_problem_buf);} -#define RECOVER(x) ),Rf_error(R_problem_buf);} -#define WARNING(x) ),Rf_warning(R_problem_buf);} -#define LOCAL_EVALUATOR /**/ -#define NULL_ENTRY /**/ -#define WARN WARNING(NULL) - - -#include "converters.h" - - -#ifdef _GNU_ -#include "RUtils.h" -#define R_logicalScalarValue(x, i) LOGICAL((x))[(i)] -#define R_integerScalarValue(x, i) INTEGER((x))[(i)] -#define R_realScalarValue(x, i) REAL((x))[(i)] -#endif - -extern HRESULT checkErrorInfo(IUnknown *obj, HRESULT status, SEXP *serr); - - -extern "C" { - - __declspec(dllexport) SEXP R_initCOM(SEXP); - - __declspec(dllexport) SEXP R_connect(SEXP className, SEXP raiseError); - - __declspec(dllexport) SEXP R_connect_hWnd(SEXP className, SEXP excel_hWnd, SEXP raiseError); - - __declspec(dllexport) SEXP R_create(SEXP className); - -#ifdef UNUSED - __declspec(dllexport) SEXP R_invoke(SEXP obj, SEXP methodName, SEXP args); -#endif - - __declspec(dllexport) SEXP R_Invoke(SEXP obj, SEXP methodName, SEXP args, SEXP type, SEXP sreturn, SEXP ids); - - __declspec(dllexport) SEXP R_getInvokeTypes(); - - __declspec(dllexport) SEXP R_getProperty(SEXP obj, SEXP propertyName, SEXP args, SEXP ids); - __declspec(dllexport) SEXP R_setProperty(SEXP obj, SEXP propertyName, SEXP value, SEXP ids); - - - __declspec(dllexport) SEXP R_getCLSIDFromName(SEXP className); - - __declspec(dllexport) SEXP R_isValidCOMObject(SEXP obj); - - /* Doesn't work. need to figure out how to get R symbols to work here - in this C++ compiled code. - extern int * INTEGER(struct SEXPREC *); - */ -} /* end of extern "C" */ - -#ifndef _GNU_ -#define GET_NAMES(x) getRNames((x)) -#endif - -SEXP R_COM_Invoke(SEXP obj, SEXP methodName, SEXP args, WORD callType, WORD doReturn, SEXP ids); -SEXP R_convertDCOMObjectToR(const VARIANT *var); -HRESULT R_getCOMArgs(SEXP args, DISPPARAMS *parms, DISPID *, int numNamedArgs, int *namedArgPos); -HRESULT R_convertRObjectToDCOM(SEXP obj, VARIANT *var); - -void COMError(HRESULT hr); - -void GetScodeString(HRESULT hr, LPTSTR buf, int bufSize); - -__declspec(dllexport) -SEXP -R_initCOM(SEXP val) -{ - SEXP ans = R_NilValue; - if(R_logicalScalarValue(val, 0)) { - CoInitialize(NULL); - } else - CoUninitialize(); - - return(ans); -} - -HRESULT -R_getCLSIDFromString(SEXP className, CLSID *classId) -{ - HRESULT hr; - const char *ptr; - int status = FALSE; - BSTR str; - - ptr = CHAR(STRING_ELT(className, 0)); - str = AsBstr(ptr); - - hr = CLSIDFromString(str, classId); - if(SUCCEEDED(hr)) { - SysFreeString(str); - return(S_OK); - } - - status = CLSIDFromProgID(str, classId); - SysFreeString(str); - - return status; -} - -__declspec(dllexport) -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); -} - - - /*XXXX This needs some work! Does it still? */ -__declspec(dllexport) -SEXP -R_connect(SEXP className, SEXP raiseError) -{ - IUnknown *unknown = NULL; - HRESULT hr; - SEXP ans = R_NilValue; - CLSID classId; - - if(R_getCLSIDFromString(className, &classId) == S_OK) { - hr = GetActiveObject(classId, NULL, &unknown); - if(SUCCEEDED(hr)) { - void *ptr; - hr = unknown->QueryInterface(IID_IDispatch, &ptr); - ans = R_createRCOMUnknownObject((void *) ptr, "COMIDispatch"); - } else { - if(LOGICAL(raiseError)[0]) { - /* From COMError.cpp - COMError */ - TCHAR buf[512]; - GetScodeString(hr, buf, sizeof(buf)/sizeof(buf[0])); - PROTECT(ans = mkString(buf)); - SET_CLASS(ans, mkString("COMErrorString")); - UNPROTECT(1); - return(ans); - } else - return(R_NilValue); - } - } else { - PROBLEM "Couldn't get clsid from the string" - WARN; - } - return(ans); -} - - -__declspec(dllexport) -SEXP -R_connect_hWnd(SEXP className, SEXP excel_hWnd, SEXP raiseError) -{ - IUnknown *unknown = NULL; - HRESULT hr; - SEXP ans = R_NilValue; - CLSID classId; - LONG_PTR l_hwnd; - HWND temp_hwdn; - if(R_getCLSIDFromString(className, &classId) == S_OK) { - l_hwnd = (LONG_PTR)INTEGER(excel_hWnd)[0]; - temp_hwdn = (HWND)l_hwnd; - hr = AccessibleObjectFromWindow(temp_hwdn, OBJID_NATIVEOM, classId, (void**)&unknown); - if(hr == S_OK) { - void *ptr; - hr = unknown->QueryInterface(IID_IDispatch, &ptr); - ans = R_createRCOMUnknownObject((void *) ptr, "COMIDispatch"); - } else { - if(LOGICAL(raiseError)[0]) { - /* From COMError.cpp - COMError */ - TCHAR buf[512]; - GetScodeString(hr, buf, sizeof(buf)/sizeof(buf[0])); - PROTECT(ans = mkString(buf)); - SET_CLASS(ans, mkString("COMErrorString")); - UNPROTECT(1); - return(ans); - } else - return(R_NilValue); - } - } else { - PROBLEM "Couldn't get clsid from the string" - WARN; - } - return(ans); -} - -/* - Routine that is used to create a COM object from its name or CLSID. -*/ -__declspec(dllexport) -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); -} - -/* - General interface from R to invoke a COM method or property accessor. - @type integer giving the invocation kind/style (e.g. property get, property put, invoke) - @sreturn logical indicating whether the return value should be converted or not. - */ -__declspec(dllexport) SEXP -R_Invoke(SEXP obj, SEXP methodName, SEXP args, SEXP stype, SEXP sreturn, SEXP ids) -{ - WORD type = R_integerScalarValue(stype, 0); - WORD doReturn = R_logicalScalarValue(sreturn, 0); - return(R_COM_Invoke(obj, methodName, args, type, doReturn, ids)); -} - -/* Utility routine to clear the variants in the argument structure of the COM call. */ -static int -clearVariants(DISPPARAMS *params) -{ - if(params->cArgs) { - for(unsigned int i = 0; i < params->cArgs; i++) { - VariantClear(¶ms->rgvarg[i]); - } - } - return(params->cArgs); -} - - - - -void -freeSysStrings(BSTR *els, int num) -{ - if(els) { - for(int i = 0; i < num ; i++) - SysFreeString(els[i]); - } -} - - -/* - 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, " %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): , 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, "\n", (int) callType);fflush(stderr); -#endif - - return(ans); -} - -__declspec(dllexport) -SEXP -R_getProperty(SEXP obj, SEXP propertyName, SEXP args, SEXP ids) -{ - return(R_COM_Invoke(obj, propertyName, args, DISPATCH_PROPERTYGET, 1, ids)); -} - -__declspec(dllexport) -SEXP -R_setProperty(SEXP obj, SEXP propertyName, SEXP value, SEXP ids) -{ - return(R_COM_Invoke(obj, propertyName, value, DISPATCH_PROPERTYPUT, 0, ids)); -} - -SEXP getArray(SAFEARRAY *arr, int dimNo, int numDims, long *indices); - - -HRESULT -R_getCOMArgs(SEXP args, DISPPARAMS *parms, DISPID *ids, int numNamedArgs, int *namedArgPositions) -{ - int numArgs = Rf_length(args), i, ctr; - if(numArgs == 0) - return(S_OK); - -#ifdef RDCOM_VERBOSE - errorLog("Converting arguments (# %d, # %d named)\n", numArgs, numNamedArgs); -#endif - - - parms->rgvarg = (VARIANT *) S_alloc(numArgs, sizeof(VARIANT)); - parms->cArgs = numArgs; - - /* If there are named arguments, then put these at the beginning of the - rgvarg*/ - if(numNamedArgs > 0) { - int namedArgCtr = 0; - VARIANT *var; - SEXP el; - SEXP names = GET_NAMES(args); - - parms->rgdispidNamedArgs = (DISPID *) S_alloc(numNamedArgs, sizeof(DISPID)); - parms->cNamedArgs = numNamedArgs; - - for(i = 0, ctr = numArgs-1; i < numArgs ; i++) { - if(strcmp(CHAR(STRING_ELT(names, i)), "") != 0) { - var = &(parms->rgvarg[namedArgCtr]); - parms->rgdispidNamedArgs[namedArgCtr] = ids[namedArgCtr + 1]; -#ifdef RDCOM_VERBOSE - errorLog("Putting named argument %d into %d\n", i+1, namedArgCtr); - Rf_PrintValue(VECTOR_ELT(args, i)); -#endif - namedArgCtr++; - } else { - var = &(parms->rgvarg[ctr]); - ctr--; - } - el = VECTOR_ELT(args, i); - VariantInit(var); - R_convertRObjectToDCOM(el, var); - } - } else { - - parms->cNamedArgs = 0; - parms->rgdispidNamedArgs = NULL; - - for(i = 0, ctr = numArgs-1; i < numArgs; i++, ctr--) { - SEXP el = VECTOR_ELT(args, i); - VariantInit(&parms->rgvarg[ctr]); - R_convertRObjectToDCOM(el, &(parms->rgvarg[ctr])); - } - } - - return(S_OK); -} - -SEXP -R_isValidCOMObject(SEXP obj) -{ - SEXP el = GET_SLOT(obj, Rf_install("ref")); - void *ptr = NULL; - - if(TYPEOF(el) != EXTPTRSXP || el == R_NilValue) - return(ScalarLogical(FALSE)); - - ptr = R_ExternalPtrAddr(el); - return(ScalarLogical(ptr != NULL)); -} - +// # Package: RDCOMClient +// # Version: 0.93-0.2 +// # Title: R-DCOM Client +// # Author: Duncan Temple Lang +// # Maintainer: Duncan Temple Lang +// # Description: Provides dynamic client-side access to (D)COM applications from within R. +// # License: GPL-2 +// # Collate: classes.R COMLists.S COMError.R com.R debug.S zzz.R runTime.S +// # URL: http://www.omegahat.net/RDCOMClient, http://www.omegahat.net +// # http://www.omegahat.net/bugs +// Some parts of code by https://github.com/jototland/ jototland@gmail.com + +#ifndef _GNU_ +#include "stdafx.h" +#include +#else +#include +#include +#include +#include +#include +#ifndef V_UI4 +# define V_UI4(X) V_UNION((X), uintVal) +#endif + +#ifdef ERROR +#undef ERROR +#endif + +#endif + + +extern "C" { +#include "RUtils.h" +#include +#include +} + +#include /* for Rf_error and Rf_warning */ + +#ifdef R_PROBLEM_BUFSIZE +#undef R_PROBLEM_BUFSIZE +#endif +#ifdef PROBLEM +#undef PROBLEM +#endif + +#ifdef MESSAGE +#undef MESSAGE +#endif +#ifdef RECOVER +#undef RECOVER +#endif + + +#ifdef WARNING +#undef WARNING +#endif +#ifdef LOCAL_EVALUATOR +#undef LOCAL_EVALUATOR +#endif + +#ifdef NULL_ENTRY +#undef NULL_ENTRY +#endif + + +#ifdef WARN +#undef WARN +#endif +#ifdef ERROR +#undef ERROR +#endif + + +#define R_PROBLEM_BUFSIZE 4096 +/* Parentheses added for FC4 with gcc4 and -D_FORTIFY_SOURCE=2 */ +#define PROBLEM {char R_problem_buf[R_PROBLEM_BUFSIZE];(snprintf)(R_problem_buf, R_PROBLEM_BUFSIZE, +#define MESSAGE {char R_problem_buf[R_PROBLEM_BUFSIZE];(snprintf)(R_problem_buf, R_PROBLEM_BUFSIZE, +#define ERROR ),Rf_error(R_problem_buf);} +#define RECOVER(x) ),Rf_error(R_problem_buf);} +#define WARNING(x) ),Rf_warning(R_problem_buf);} +#define LOCAL_EVALUATOR /**/ +#define NULL_ENTRY /**/ +#define WARN WARNING(NULL) + + +#include "converters.h" + + +#ifdef _GNU_ +#include "RUtils.h" +#define R_logicalScalarValue(x, i) LOGICAL((x))[(i)] +#define R_integerScalarValue(x, i) INTEGER((x))[(i)] +#define R_realScalarValue(x, i) REAL((x))[(i)] +#endif + +extern HRESULT checkErrorInfo(IUnknown *obj, HRESULT status, SEXP *serr); + + +extern "C" { + + __declspec(dllexport) SEXP R_initCOM(SEXP); + + __declspec(dllexport) SEXP R_connect(SEXP className, SEXP raiseError); + + __declspec(dllexport) SEXP R_connect_hWnd(SEXP className, SEXP excel_hWnd, SEXP raiseError); + + __declspec(dllexport) SEXP R_create(SEXP className); + +#ifdef UNUSED + __declspec(dllexport) SEXP R_invoke(SEXP obj, SEXP methodName, SEXP args); +#endif + + __declspec(dllexport) SEXP R_Invoke(SEXP obj, SEXP methodName, SEXP args, SEXP type, SEXP sreturn, SEXP ids); + + __declspec(dllexport) SEXP R_getInvokeTypes(); + + __declspec(dllexport) SEXP R_getProperty(SEXP obj, SEXP propertyName, SEXP args, SEXP ids); + __declspec(dllexport) SEXP R_setProperty(SEXP obj, SEXP propertyName, SEXP value, SEXP ids); + + + __declspec(dllexport) SEXP R_getCLSIDFromName(SEXP className); + + __declspec(dllexport) SEXP R_isValidCOMObject(SEXP obj); + + /* Doesn't work. need to figure out how to get R symbols to work here + in this C++ compiled code. + extern int * INTEGER(struct SEXPREC *); + */ +} /* end of extern "C" */ + +#ifndef _GNU_ +#define GET_NAMES(x) getRNames((x)) +#endif + +SEXP R_COM_Invoke(SEXP obj, SEXP methodName, SEXP args, WORD callType, WORD doReturn, SEXP ids); +SEXP R_convertDCOMObjectToR(const VARIANT *var); +HRESULT R_getCOMArgs(SEXP args, DISPPARAMS *parms, DISPID *, int numNamedArgs, int *namedArgPos); +HRESULT R_convertRObjectToDCOM(SEXP obj, VARIANT *var); + +void COMError(HRESULT hr); + +void GetScodeString(HRESULT hr, LPTSTR buf, int bufSize); + +__declspec(dllexport) +SEXP +R_initCOM(SEXP val) +{ + SEXP ans = R_NilValue; + if(R_logicalScalarValue(val, 0)) { + CoInitialize(NULL); + } else + CoUninitialize(); + + return(ans); +} + +HRESULT +R_getCLSIDFromString(SEXP className, CLSID *classId) +{ + HRESULT hr; + const char *ptr; + int status = FALSE; + BSTR str; + + ptr = CHAR(STRING_ELT(className, 0)); + str = AsBstr(ptr); + + hr = CLSIDFromString(str, classId); + if(SUCCEEDED(hr)) { + SysFreeString(str); + return(S_OK); + } + + status = CLSIDFromProgID(str, classId); + SysFreeString(str); + + return status; +} + +__declspec(dllexport) +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); +} + + + /*XXXX This needs some work! Does it still? */ +__declspec(dllexport) +SEXP +R_connect(SEXP className, SEXP raiseError) +{ + IUnknown *unknown = NULL; + HRESULT hr; + SEXP ans = R_NilValue; + CLSID classId; + + if(R_getCLSIDFromString(className, &classId) == S_OK) { + hr = GetActiveObject(classId, NULL, &unknown); + if(SUCCEEDED(hr)) { + void *ptr; + hr = unknown->QueryInterface(IID_IDispatch, &ptr); + ans = R_createRCOMUnknownObject((void *) ptr, "COMIDispatch"); + } else { + if(LOGICAL(raiseError)[0]) { + /* From COMError.cpp - COMError */ + TCHAR buf[512]; + GetScodeString(hr, buf, sizeof(buf)/sizeof(buf[0])); + PROTECT(ans = mkString(buf)); + SET_CLASS(ans, mkString("COMErrorString")); + UNPROTECT(1); + return(ans); + } else + return(R_NilValue); + } + } else { + PROBLEM "Couldn't get clsid from the string" + WARN; + } + return(ans); +} + + +__declspec(dllexport) +SEXP +R_connect_hWnd(SEXP className, SEXP excel_hWnd, SEXP raiseError) +{ + IUnknown *unknown = NULL; + HRESULT hr; + SEXP ans = R_NilValue; + CLSID classId; + LONG_PTR l_hwnd; + HWND temp_hwdn; + if(R_getCLSIDFromString(className, &classId) == S_OK) { + l_hwnd = (LONG_PTR)INTEGER(excel_hWnd)[0]; + temp_hwdn = (HWND)l_hwnd; + hr = AccessibleObjectFromWindow(temp_hwdn, OBJID_NATIVEOM, classId, (void**)&unknown); + if(hr == S_OK) { + void *ptr; + hr = unknown->QueryInterface(IID_IDispatch, &ptr); + ans = R_createRCOMUnknownObject((void *) ptr, "COMIDispatch"); + } else { + if(LOGICAL(raiseError)[0]) { + /* From COMError.cpp - COMError */ + TCHAR buf[512]; + GetScodeString(hr, buf, sizeof(buf)/sizeof(buf[0])); + PROTECT(ans = mkString(buf)); + SET_CLASS(ans, mkString("COMErrorString")); + UNPROTECT(1); + return(ans); + } else + return(R_NilValue); + } + } else { + PROBLEM "Couldn't get clsid from the string" + WARN; + } + return(ans); +} + +/* + Routine that is used to create a COM object from its name or CLSID. +*/ +__declspec(dllexport) +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); +} + +/* + General interface from R to invoke a COM method or property accessor. + @type integer giving the invocation kind/style (e.g. property get, property put, invoke) + @sreturn logical indicating whether the return value should be converted or not. + */ +__declspec(dllexport) SEXP +R_Invoke(SEXP obj, SEXP methodName, SEXP args, SEXP stype, SEXP sreturn, SEXP ids) +{ + WORD type = R_integerScalarValue(stype, 0); + WORD doReturn = R_logicalScalarValue(sreturn, 0); + return(R_COM_Invoke(obj, methodName, args, type, doReturn, ids)); +} + +/* Utility routine to clear the variants in the argument structure of the COM call. */ +static int +clearVariants(DISPPARAMS *params) +{ + if(params->cArgs) { + for(unsigned int i = 0; i < params->cArgs; i++) { + VariantClear(¶ms->rgvarg[i]); + } + } + return(params->cArgs); +} + + + + +void +freeSysStrings(BSTR *els, int num) +{ + if(els) { + for(int i = 0; i < num ; i++) + SysFreeString(els[i]); + } +} + + +/* + 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, " %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): , 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, "\n", (int) callType);fflush(stderr); +#endif + + return(ans); +} + +__declspec(dllexport) +SEXP +R_getProperty(SEXP obj, SEXP propertyName, SEXP args, SEXP ids) +{ + return(R_COM_Invoke(obj, propertyName, args, DISPATCH_PROPERTYGET, 1, ids)); +} + +__declspec(dllexport) +SEXP +R_setProperty(SEXP obj, SEXP propertyName, SEXP value, SEXP ids) +{ + return(R_COM_Invoke(obj, propertyName, value, DISPATCH_PROPERTYPUT, 0, ids)); +} + +SEXP getArray(SAFEARRAY *arr, int dimNo, int numDims, long *indices); + + +HRESULT +R_getCOMArgs(SEXP args, DISPPARAMS *parms, DISPID *ids, int numNamedArgs, int *namedArgPositions) +{ + int numArgs = Rf_length(args), i, ctr; + if(numArgs == 0) + return(S_OK); + +#ifdef RDCOM_VERBOSE + errorLog("Converting arguments (# %d, # %d named)\n", numArgs, numNamedArgs); +#endif + + + parms->rgvarg = (VARIANT *) S_alloc(numArgs, sizeof(VARIANT)); + parms->cArgs = numArgs; + + /* If there are named arguments, then put these at the beginning of the + rgvarg*/ + if(numNamedArgs > 0) { + int namedArgCtr = 0; + VARIANT *var; + SEXP el; + SEXP names = GET_NAMES(args); + + parms->rgdispidNamedArgs = (DISPID *) S_alloc(numNamedArgs, sizeof(DISPID)); + parms->cNamedArgs = numNamedArgs; + + for(i = 0, ctr = numArgs-1; i < numArgs ; i++) { + if(strcmp(CHAR(STRING_ELT(names, i)), "") != 0) { + var = &(parms->rgvarg[namedArgCtr]); + parms->rgdispidNamedArgs[namedArgCtr] = ids[namedArgCtr + 1]; +#ifdef RDCOM_VERBOSE + errorLog("Putting named argument %d into %d\n", i+1, namedArgCtr); + Rf_PrintValue(VECTOR_ELT(args, i)); +#endif + namedArgCtr++; + } else { + var = &(parms->rgvarg[ctr]); + ctr--; + } + el = VECTOR_ELT(args, i); + VariantInit(var); + R_convertRObjectToDCOM(el, var); + } + } else { + + parms->cNamedArgs = 0; + parms->rgdispidNamedArgs = NULL; + + for(i = 0, ctr = numArgs-1; i < numArgs; i++, ctr--) { + SEXP el = VECTOR_ELT(args, i); + VariantInit(&parms->rgvarg[ctr]); + R_convertRObjectToDCOM(el, &(parms->rgvarg[ctr])); + } + } + + return(S_OK); +} + +SEXP +R_isValidCOMObject(SEXP obj) +{ + SEXP el = GET_SLOT(obj, Rf_install("ref")); + void *ptr = NULL; + + if(TYPEOF(el) != EXTPTRSXP || el == R_NilValue) + return(ScalarLogical(FALSE)); + + ptr = R_ExternalPtrAddr(el); + return(ScalarLogical(ptr != NULL)); +} + diff --git a/src/converters.cpp b/src/converters.cpp index ad07726..29d1088 100644 --- a/src/converters.cpp +++ b/src/converters.cpp @@ -1,952 +1,952 @@ -// # Package: RDCOMClient -// # Version: 0.93-0.2 -// # Title: R-DCOM Client -// # Author: Duncan Temple Lang -// # Maintainer: Duncan Temple Lang -// # Description: Provides dynamic client-side access to (D)COM applications from within R. -// # License: GPL-2 -// # Collate: classes.R COMLists.S COMError.R com.R debug.S zzz.R runTime.S -// # URL: http://www.omegahat.net/RDCOMClient, http://www.omegahat.net -// # http://www.omegahat.net/bugs -// Some parts of code by https://github.com/jototland/ jototland@gmail.com - -#include "RCOMObject.h" -#include -#include -#include - -// #undef ERROR -extern "C" { -#include "RUtils.h" -#include -#include - SEXP R_getDynamicVariantValue(SEXP ref); - SEXP R_setDynamicVariantValue(SEXP ref, SEXP value); -} - -#include "converters.h" - -#include /* for Rf_error and Rf_warning */ - -#ifdef R_PROBLEM_BUFSIZE -#undef R_PROBLEM_BUFSIZE -#endif -#ifdef PROBLEM -#undef PROBLEM -#endif - -#ifdef MESSAGE -#undef MESSAGE -#endif -#ifdef RECOVER -#undef RECOVER -#endif - - -#ifdef WARNING -#undef WARNING -#endif -#ifdef LOCAL_EVALUATOR -#undef LOCAL_EVALUATOR -#endif - -#ifdef NULL_ENTRY -#undef NULL_ENTRY -#endif - - -#ifdef WARN -#undef WARN -#endif -#ifdef ERROR -#undef ERROR -#endif - - -#define R_PROBLEM_BUFSIZE 4096 -/* Parentheses added for FC4 with gcc4 and -D_FORTIFY_SOURCE=2 */ -#define PROBLEM {char R_problem_buf[R_PROBLEM_BUFSIZE];(snprintf)(R_problem_buf, R_PROBLEM_BUFSIZE, -#define MESSAGE {char R_problem_buf[R_PROBLEM_BUFSIZE];(snprintf)(R_problem_buf, R_PROBLEM_BUFSIZE, -#define ERROR ),Rf_error(R_problem_buf);} -#define RECOVER(x) ),Rf_error(R_problem_buf);} -#define WARNING(x) ),Rf_warning(R_problem_buf);} -#define LOCAL_EVALUATOR /**/ -#define NULL_ENTRY /**/ -#define WARN WARNING(NULL) - - -static SEXP convertArrayToR(const VARIANT *var); -void GetScodeString(HRESULT hr, LPTSTR buf, int bufSize); -SEXP UnList(SEXP ans); - -BSTR -AsBstr(const char *str) -{ - BSTR ans = NULL; - if(!str) - return(NULL); - - int size = strlen(str); - int wideSize = 2 * size; - LPOLESTR wstr = (LPWSTR) S_alloc(wideSize, sizeof(OLECHAR)); - if(MultiByteToWideChar(CP_ACP, 0, str, size, wstr, wideSize) == 0 && str[0]) { - PROBLEM "Can't create BSTR for '%s'", str - ERROR; - } - - ans = SysAllocStringLen(wstr, size); - - return(ans); -} - -char * -FromBstr(BSTR str) -{ - char *ptr = NULL; - - if(!str) - return(NULL); - - int len = WideCharToMultiByte(CP_ACP, 0, str, -1, NULL, 0, NULL, NULL); - - if(len < 1) - len = 0; - - ptr = (char *) S_alloc(len+1, sizeof(char)); - ptr[len] = '\0'; - if(len > 0) { - WideCharToMultiByte(CP_ACP, 0, str, -1, ptr, len, NULL, NULL); - } - - return(ptr); -} - - -/* - Get the number of dimensions. - For each of these dimensions, get the lower and upper bound and iterate - over the elements. -*/ -static SEXP -convertArrayToR(const VARIANT *var) -{ - SAFEARRAY *arr; - SEXP ans; - UINT dim; - - if(V_ISBYREF(var)) - arr = *V_ARRAYREF(var); - else - arr = V_ARRAY(var); - - dim = SafeArrayGetDim(arr); - long *indices = (long*) S_alloc(dim, sizeof(long)); // new long[dim]; - ans = getArray(arr, dim, dim, indices); - - 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); -} - -SEXP -UnList(SEXP ans) -{ - SEXP e, val; - int errorOccurred; - - PROTECT(e = allocVector(LANGSXP, 2)); - SETCAR(e, Rf_install("unlist")); - SETCAR(CDR(e), ans); - val = R_tryEval(e, R_GlobalEnv, &errorOccurred); - UNPROTECT(1); - - return(errorOccurred ? ans : val); -} - -void -R_typelib_finalizer(SEXP obj) -{ - R_ClearExternalPtr(obj); -} - - -void -R_Variant_finalizer(SEXP s) -{ - VARIANT *var; - var = (VARIANT *) R_ExternalPtrAddr(s); - if(var) { - VariantClear(var); - free(var); - R_ClearExternalPtr(s); - } -} - -SEXP -createRVariantObject(VARIANT *var, VARTYPE kind) -{ - const char *className; - SEXP klass, ans, tmp; - VARIANT *dupvar; - switch(kind) { - case VT_DATE: - className = "DateVARIANT"; - break; - case VT_CY: - className = "CurrencyVARIANT"; - break; - - default: - className = "VARIANT"; - } - - PROTECT(klass = MAKE_CLASS(className)); - if(klass == NULL || klass == R_NilValue) { - PROBLEM "Can't locate S4 class definition %s", className - ERROR; - } - - dupvar = (VARIANT *) malloc(sizeof(VARIANT)); - VariantCopyInd(dupvar, var); - - PROTECT(ans = NEW(klass)); - PROTECT(tmp = R_MakeExternalPtr(dupvar, Rf_install(className), R_NilValue)); - R_RegisterCFinalizer(tmp, R_Variant_finalizer); - SET_SLOT(ans, Rf_install("ref"), tmp); - UNPROTECT(1); - - PROTECT(tmp = NEW_INTEGER(1)); - INTEGER(tmp)[0] = kind; - SET_SLOT(ans, Rf_install("kind"), tmp); - - UNPROTECT(3); - return(ans); -} - -/** - Turn a variant into an S object with a special class - such as COMDate or COMCurrency which is simply an extension - of numeric. -*/ -SEXP -numberFromVariant(VARIANT *var, VARTYPE type) -{ - SEXP ans; - SEXP klass; - const char *tmpName = NULL; - - switch(type) { - case VT_CY: - tmpName = "COMCurrency"; - break; - case VT_DATE: - tmpName = (char *) "COMDate"; - break; - case VT_HRESULT: - tmpName = (char *) "HResult"; - break; - case VT_DECIMAL: - tmpName = (char *) "COMDecimal"; - break; - default: - PROBLEM "numberFromVariant called with unsupported variant type." - ERROR; - } - PROTECT(klass = MAKE_CLASS(tmpName)); - PROTECT(ans = NEW(klass)); - ans = R_do_slot_assign(ans, mkString(".Data"), R_scalarReal(V_R8(var))); - // SET_SLOT(ans, Rf_install(".Data"), R_scalarReal(V_R8(var))); - UNPROTECT(2); - - return(ans); -} - - -static SEXP -createVariantRef(VARIANT *var, VARTYPE baseType) -{ - SEXP e, ans = R_NilValue, ref; - PROTECT(e = allocVector(LANGSXP, 3)); - SETCAR(e, Rf_install("createDynamicVariantReference")); - ref = R_MakeExternalPtr((void *) var, Rf_install("VARIANTReference"), R_NilValue); - SETCAR(CDR(e), ref); - SETCAR(CDR(CDR(e)), ScalarInteger(baseType)); - - ans = R_tryEval(e, R_GlobalEnv, NULL); - UNPROTECT(1); - - return(ans); -} - -static VARIANT * -R_getVariantRef(SEXP ref) -{ - VARIANT *p; - - if(TYPEOF(ref) != EXTPTRSXP) { - PROBLEM "Argument to R_getVariantRef must be an external pointer" - ERROR; - } - - if(EXTPTR_TAG(ref) != Rf_install("VARIANTReference")) { - PROBLEM "Argument to R_getVariantRef does not have the correct tag." - ERROR; - } - - p = (VARIANT *) R_ExternalPtrAddr(ref); - return(p); -} - -SEXP -R_getDynamicVariantValue(SEXP ref) -{ - VARIANT *var; - VARTYPE rtype; - - var = R_getVariantRef(ref); - rtype = V_VT(var) & (~ VT_BYREF); - switch(rtype) { - case VT_BOOL: - return(ScalarLogical(*V_BOOLREF(var))); - break; - case VT_I4: - return(ScalarInteger(*V_I4REF(var))); - break; - case VT_R8: - return(ScalarReal(*V_R8REF(var))); - break; - default: - return(R_NilValue); - } - - return(R_NilValue); -} - - - -SEXP -R_setDynamicVariantValue(SEXP ref, SEXP val) -{ - VARIANT *var; - VARTYPE rtype; - - var = R_getVariantRef(ref); - rtype = V_VT(var) & (~ VT_BYREF); - switch(rtype) { - case VT_BOOL: - *V_BOOLREF(var) = LOGICAL(val)[0]; - break; - case VT_I4: - *V_I4REF(var) = INTEGER(val)[0]; - break; - case VT_R8: - *V_R8REF(var) = REAL(val)[0]; - break; - default: - return(R_NilValue); - } - - return(R_NilValue); -} - - -/* Taken from connect.cpp in RDCOMClient. */ - -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_ERROR: // to get errors such as #NUM as NaN in R - ans = R_scalarReal(R_NaN); - 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_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); -} - -VARTYPE -getDCOMType(SEXP obj) -{ - VARTYPE val = VT_UNKNOWN; - - switch(TYPEOF(obj)) { - case REALSXP: - val = VT_R8; - break; - case LGLSXP: - val = VT_BOOL; - break; - case INTSXP: - val = VT_I4; - break; - case STRSXP: - val = VT_BSTR; - break; - case VECSXP: - val = VT_VARIANT; - break; - default: - break; - } - - return(val); -} - -SAFEARRAY* -createRDCOMArray(SEXP obj, VARIANT *var) -{ - VARTYPE type; - unsigned int cDims = 1, len; - SAFEARRAYBOUND bounds[1]; - SAFEARRAY *arr; - void *data; - - len = Rf_length(obj); - bounds[0].lLbound = 0; - bounds[0].cElements = len; - - type = getDCOMType(obj); - arr = SafeArrayCreate(type, cDims, bounds); - - HRESULT hr = SafeArrayAccessData(arr, (void**) &data); - if(hr != S_OK) { - //std::cerr <<"Problems accessing data" << std::endl; - REprintf("Problems accessing data\n"); - SafeArrayDestroy(arr); - return(NULL); - } - - switch(TYPEOF(obj)) { - case REALSXP: - memcpy(data, REAL(obj), sizeof(double) * len); - break; - case INTSXP: - memcpy(data, INTEGER(obj), sizeof(LOGICAL(obj)[0]) * len); - break; - case LGLSXP: - for(unsigned int i = 0 ; i < len ; i++) - ((bool *) data)[i] = LOGICAL(obj)[i]; - break; - case STRSXP: - for(unsigned int i = 0 ; i < len ; i++) - ((BSTR *) data)[i] = AsBstr(getRString(obj, i)); - break; - case VECSXP: - for(unsigned int i = 0 ; i < len ; i++) { - VARIANT *v = &(((VARIANT *) data)[i]); - VariantInit(v); - R_convertRObjectToDCOM(VECTOR_ELT(obj, i), v); - } - break; - - default: - //std::cerr <<"Array case not handled yet for R type " << TYPEOF(obj) << std::endl; - REprintf("Array case not handled yet for R type %d\n", TYPEOF(obj)); - break; - } - - SafeArrayUnaccessData(arr); - - if(var) { - V_VT(var) = VT_ARRAY | type; - V_ARRAY(var) = arr; - } - - return(arr); -} - -HRESULT -createGenericCOMObject(SEXP obj, VARIANT *var) -{ - SEXP e, val; - int errorOccurred; - - /* Make certain RDCOMServer is loaded as this might be invoked - as part of RDCOMClient. */ - PROTECT(e = allocVector(LANGSXP, 3)); - SETCAR(e, Rf_install("require")); - SETCAR(CDR(e), Rf_install("RDCOMServer")); - SETCAR(CDR(CDR(e)), val = allocVector(LGLSXP, 1)); - INTEGER(val)[0] = TRUE; - SET_TAG(CDR(CDR(e)), Rf_install("quiet")); - - val = R_tryEval(e, R_GlobalEnv, &errorOccurred); - UNPROTECT(1); - if(!LOGICAL(val)[0]) { - PROBLEM "Can't attach the RDCOMServer package needed to create a generic COM object" - ERROR; - return(S_FALSE); - } - - PROTECT(e = allocVector(LANGSXP, 2)); - SETCAR(e, Rf_install("createCOMObject")); - SETCAR(CDR(e), obj); - val = R_tryEval(e, R_GlobalEnv, &errorOccurred); - if(errorOccurred) { - UNPROTECT(1); - PROBLEM "Can't create COM object" - ERROR; - return(S_FALSE); - } - - RCOMObject *robj; - if(TYPEOF(val) != EXTPTRSXP) - return(S_FALSE); - - robj = (RCOMObject *) R_ExternalPtrAddr(val); - V_VT(var) = VT_DISPATCH; - V_DISPATCH(var) = robj; - - return(S_OK); -} - -HRESULT -R_convertRObjectToDCOM(SEXP obj, VARIANT *var) -{ - HRESULT status; - int type = R_typeof(obj); - - if(!var) - return(S_FALSE); - -#ifdef RDCOM_VERBOSE - errorLog("Type of argument %d\n", type); -#endif - - if(type == EXTPTRSXP && EXTPTR_TAG(obj) == Rf_install("R_VARIANT")) { - VARIANT *tmp; - tmp = (VARIANT *) R_ExternalPtrAddr(obj); - if(tmp) { - //XXX - VariantCopy(var, tmp); - return(S_OK); - } - } - - if(ISCOMIDispatch(obj)) { - IDispatch *ptr; - ptr = (IDispatch *) derefRIDispatch(obj); - V_VT(var) = VT_DISPATCH; - V_DISPATCH(var) = ptr; - //XX - ptr->AddRef(); - return(S_OK); - } - - if(ISSInstanceOf(obj, "COMDate")) { - double val; - val = NUMERIC_DATA(GET_SLOT(obj, Rf_install(".Data")))[0]; - V_VT(var) = VT_DATE; - V_DATE(var) = val; - return(S_OK); - } else if(ISSInstanceOf(obj, "COMCurrency")) { - double val; - val = NUMERIC_DATA(GET_SLOT(obj, Rf_install(".Data")))[0]; - V_VT(var) = VT_R8; - V_R8(var) = val; - VariantChangeType(var, var, 0, VT_CY); - return(S_OK); - } else if(ISSInstanceOf(obj, "COMDecimal")) { - double val; - val = NUMERIC_DATA(GET_SLOT(obj, Rf_install(".Data")))[0]; - V_VT(var) = VT_R8; - V_R8(var) = val; - VariantChangeType(var, var, 0, VT_DECIMAL); - return(S_OK); - } - - - /* We have a complex object and we are not going to try to convert it directly - but instead create an COM server object to represent it to the outside world. */ - if((type == VECSXP && Rf_length(GET_NAMES(obj))) || Rf_length(GET_CLASS(obj)) > 0 || isMatrix(obj)) { - status = createGenericCOMObject(obj, var); - if(status == S_OK) - return(S_OK); - } - - if(Rf_length(obj) == 0) { - V_VT(var) = VT_VOID; - return(S_OK); - } - - if(type == VECSXP || Rf_length(obj) > 1) { - createRDCOMArray(obj, var); - return(S_OK); - } - - switch(type) { - case STRSXP: - V_VT(var) = VT_BSTR; - V_BSTR(var) = AsBstr(getRString(obj, 0)); - break; - - case INTSXP: - V_VT(var) = VT_I4; - V_I4(var) = R_integerScalarValue(obj, 0); - break; - - case REALSXP: - V_VT(var) = VT_R8; - V_R8(var) = R_realScalarValue(obj, 0); - break; - - case LGLSXP: - V_VT(var) = VT_BOOL; - V_BOOL(var) = R_logicalScalarValue(obj, 0) ? VARIANT_TRUE : VARIANT_FALSE; - break; - - case VECSXP: - break; - } - - return(S_OK); -} - -extern "C" { - void registerCOMObject(void *, int); -} - -void -RDCOM_finalizer(SEXP s) -{ - IUnknown *ptr = (IUnknown*) derefRDCOMPointer(s); - if(ptr) { -#ifdef ANNOUNCE_COM_CALLS - fprintf(stderr, "Releasing COM object %p\n", ptr);fflush(stderr); -#endif - -#ifdef REGISTER_COM_OBJECTS_WITH_S - registerCOMObject(ptr, 0); -#endif - - //XXX - ptr->Release(); -#ifdef ANNOUNCE_COM_CALLS - fprintf(stderr, "Released COM object %p\n", ptr);fflush(stderr); -#endif - R_ClearExternalPtr(s); - } -} - -void -RDCOM_SafeArray_finalizer(SEXP s) -{ - SAFEARRAY *arr; - arr = (SAFEARRAY*) R_ExternalPtrAddr(s); - if(arr) { - SafeArrayDestroy(arr); - R_ClearExternalPtr(s); - } -} - -SEXP -R_create2DArray(SEXP obj) -{ - SAFEARRAYBOUND bounds[2] = {{0, 0}, {0, 0}};; - SAFEARRAY *arr; - void *data, *el; - VARTYPE type = VT_R8; - SEXP dim = GET_DIM(obj); - int integer; - double real; - BSTR bstr; - - - bounds[0].cElements = INTEGER(dim)[0]; - bounds[1].cElements = INTEGER(dim)[1]; - - type = getDCOMType(obj); - - arr = SafeArrayCreate(type, 2, bounds); - SafeArrayAccessData(arr, (void**) &data); - - long indices[2]; - UINT i, j, ctr = 0; - for(j = 0 ; j < bounds[1].cElements; j++) { - indices[1] = j; - for(i = 0; i < bounds[0].cElements; i++, ctr++) { - indices[0] = i; - switch(TYPEOF(obj)) { - case LGLSXP: - integer = (LOGICAL(obj)[ctr] ? 1:0); - el = &integer; - break; - case REALSXP: - real = REAL(obj)[ctr]; - el = ℜ - break; - case INTSXP: - integer = INTEGER(obj)[ctr]; - el = &integer; - break; - case STRSXP: - bstr = AsBstr(CHAR(STRING_ELT(obj, ctr))); - el = (void*) bstr; - break; - default: - continue; - break; - } - - SafeArrayPutElement(arr, indices, el); - } - } - SafeArrayUnaccessData(arr); - - VARIANT *var; - var = (VARIANT*) malloc(sizeof(VARIANT)); - VariantInit(var); - V_VT(var) = VT_ARRAY | type; - V_ARRAY(var) = arr; - - SEXP ans; - PROTECT(ans = R_MakeExternalPtr((void*) var, Rf_install("R_VARIANT"), R_NilValue)); - R_RegisterCFinalizer(ans, RDCOM_SafeArray_finalizer); - UNPROTECT(1); - return(ans); -} - -extern "C" -SEXP -R_createVariant(SEXP type) -{ - VARIANT var; - VariantInit(&var); - return(createRVariantObject(&var, INTEGER_DATA(type)[0])); -} - - -SEXP -R_setVariant(SEXP svar, SEXP value, SEXP type) -{ - VARIANT *var; - var = (VARIANT *)R_ExternalPtrAddr(GET_SLOT(svar, Rf_install("ref"))); - if(!var) { - PROBLEM "Null VARIANT value passed to R_setVariant. Was this saved in another session\n" - ERROR; - } - - HRESULT hr; - hr = R_convertRObjectToDCOM(value, var); - - SEXP ans; - ans = NEW_LOGICAL(1); - LOGICAL_DATA(ans)[0] = hr == S_OK ? TRUE : FALSE; - return(ans); -} - - +// # Package: RDCOMClient +// # Version: 0.93-0.2 +// # Title: R-DCOM Client +// # Author: Duncan Temple Lang +// # Maintainer: Duncan Temple Lang +// # Description: Provides dynamic client-side access to (D)COM applications from within R. +// # License: GPL-2 +// # Collate: classes.R COMLists.S COMError.R com.R debug.S zzz.R runTime.S +// # URL: http://www.omegahat.net/RDCOMClient, http://www.omegahat.net +// # http://www.omegahat.net/bugs +// Some parts of code by https://github.com/jototland/ jototland@gmail.com + +#include "RCOMObject.h" +#include +#include +#include + +// #undef ERROR +extern "C" { +#include "RUtils.h" +#include +#include + SEXP R_getDynamicVariantValue(SEXP ref); + SEXP R_setDynamicVariantValue(SEXP ref, SEXP value); +} + +#include "converters.h" + +#include /* for Rf_error and Rf_warning */ + +#ifdef R_PROBLEM_BUFSIZE +#undef R_PROBLEM_BUFSIZE +#endif +#ifdef PROBLEM +#undef PROBLEM +#endif + +#ifdef MESSAGE +#undef MESSAGE +#endif +#ifdef RECOVER +#undef RECOVER +#endif + + +#ifdef WARNING +#undef WARNING +#endif +#ifdef LOCAL_EVALUATOR +#undef LOCAL_EVALUATOR +#endif + +#ifdef NULL_ENTRY +#undef NULL_ENTRY +#endif + + +#ifdef WARN +#undef WARN +#endif +#ifdef ERROR +#undef ERROR +#endif + + +#define R_PROBLEM_BUFSIZE 4096 +/* Parentheses added for FC4 with gcc4 and -D_FORTIFY_SOURCE=2 */ +#define PROBLEM {char R_problem_buf[R_PROBLEM_BUFSIZE];(snprintf)(R_problem_buf, R_PROBLEM_BUFSIZE, +#define MESSAGE {char R_problem_buf[R_PROBLEM_BUFSIZE];(snprintf)(R_problem_buf, R_PROBLEM_BUFSIZE, +#define ERROR ),Rf_error(R_problem_buf);} +#define RECOVER(x) ),Rf_error(R_problem_buf);} +#define WARNING(x) ),Rf_warning(R_problem_buf);} +#define LOCAL_EVALUATOR /**/ +#define NULL_ENTRY /**/ +#define WARN WARNING(NULL) + + +static SEXP convertArrayToR(const VARIANT *var); +void GetScodeString(HRESULT hr, LPTSTR buf, int bufSize); +SEXP UnList(SEXP ans); + +BSTR +AsBstr(const char *str) +{ + BSTR ans = NULL; + if(!str) + return(NULL); + + int size = strlen(str); + int wideSize = 2 * size; + LPOLESTR wstr = (LPWSTR) S_alloc(wideSize, sizeof(OLECHAR)); + if(MultiByteToWideChar(CP_ACP, 0, str, size, wstr, wideSize) == 0 && str[0]) { + PROBLEM "Can't create BSTR for '%s'", str + ERROR; + } + + ans = SysAllocStringLen(wstr, size); + + return(ans); +} + +char * +FromBstr(BSTR str) +{ + char *ptr = NULL; + + if(!str) + return(NULL); + + int len = WideCharToMultiByte(CP_ACP, 0, str, -1, NULL, 0, NULL, NULL); + + if(len < 1) + len = 0; + + ptr = (char *) S_alloc(len+1, sizeof(char)); + ptr[len] = '\0'; + if(len > 0) { + WideCharToMultiByte(CP_ACP, 0, str, -1, ptr, len, NULL, NULL); + } + + return(ptr); +} + + +/* + Get the number of dimensions. + For each of these dimensions, get the lower and upper bound and iterate + over the elements. +*/ +static SEXP +convertArrayToR(const VARIANT *var) +{ + SAFEARRAY *arr; + SEXP ans; + UINT dim; + + if(V_ISBYREF(var)) + arr = *V_ARRAYREF(var); + else + arr = V_ARRAY(var); + + dim = SafeArrayGetDim(arr); + long *indices = (long*) S_alloc(dim, sizeof(long)); // new long[dim]; + ans = getArray(arr, dim, dim, indices); + + 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); +} + +SEXP +UnList(SEXP ans) +{ + SEXP e, val; + int errorOccurred; + + PROTECT(e = allocVector(LANGSXP, 2)); + SETCAR(e, Rf_install("unlist")); + SETCAR(CDR(e), ans); + val = R_tryEval(e, R_GlobalEnv, &errorOccurred); + UNPROTECT(1); + + return(errorOccurred ? ans : val); +} + +void +R_typelib_finalizer(SEXP obj) +{ + R_ClearExternalPtr(obj); +} + + +void +R_Variant_finalizer(SEXP s) +{ + VARIANT *var; + var = (VARIANT *) R_ExternalPtrAddr(s); + if(var) { + VariantClear(var); + free(var); + R_ClearExternalPtr(s); + } +} + +SEXP +createRVariantObject(VARIANT *var, VARTYPE kind) +{ + const char *className; + SEXP klass, ans, tmp; + VARIANT *dupvar; + switch(kind) { + case VT_DATE: + className = "DateVARIANT"; + break; + case VT_CY: + className = "CurrencyVARIANT"; + break; + + default: + className = "VARIANT"; + } + + PROTECT(klass = MAKE_CLASS(className)); + if(klass == NULL || klass == R_NilValue) { + PROBLEM "Can't locate S4 class definition %s", className + ERROR; + } + + dupvar = (VARIANT *) malloc(sizeof(VARIANT)); + VariantCopyInd(dupvar, var); + + PROTECT(ans = NEW(klass)); + PROTECT(tmp = R_MakeExternalPtr(dupvar, Rf_install(className), R_NilValue)); + R_RegisterCFinalizer(tmp, R_Variant_finalizer); + SET_SLOT(ans, Rf_install("ref"), tmp); + UNPROTECT(1); + + PROTECT(tmp = NEW_INTEGER(1)); + INTEGER(tmp)[0] = kind; + SET_SLOT(ans, Rf_install("kind"), tmp); + + UNPROTECT(3); + return(ans); +} + +/** + Turn a variant into an S object with a special class + such as COMDate or COMCurrency which is simply an extension + of numeric. +*/ +SEXP +numberFromVariant(VARIANT *var, VARTYPE type) +{ + SEXP ans; + SEXP klass; + const char *tmpName = NULL; + + switch(type) { + case VT_CY: + tmpName = "COMCurrency"; + break; + case VT_DATE: + tmpName = (char *) "COMDate"; + break; + case VT_HRESULT: + tmpName = (char *) "HResult"; + break; + case VT_DECIMAL: + tmpName = (char *) "COMDecimal"; + break; + default: + PROBLEM "numberFromVariant called with unsupported variant type." + ERROR; + } + PROTECT(klass = MAKE_CLASS(tmpName)); + PROTECT(ans = NEW(klass)); + ans = R_do_slot_assign(ans, mkString(".Data"), R_scalarReal(V_R8(var))); + // SET_SLOT(ans, Rf_install(".Data"), R_scalarReal(V_R8(var))); + UNPROTECT(2); + + return(ans); +} + + +static SEXP +createVariantRef(VARIANT *var, VARTYPE baseType) +{ + SEXP e, ans = R_NilValue, ref; + PROTECT(e = allocVector(LANGSXP, 3)); + SETCAR(e, Rf_install("createDynamicVariantReference")); + ref = R_MakeExternalPtr((void *) var, Rf_install("VARIANTReference"), R_NilValue); + SETCAR(CDR(e), ref); + SETCAR(CDR(CDR(e)), ScalarInteger(baseType)); + + ans = R_tryEval(e, R_GlobalEnv, NULL); + UNPROTECT(1); + + return(ans); +} + +static VARIANT * +R_getVariantRef(SEXP ref) +{ + VARIANT *p; + + if(TYPEOF(ref) != EXTPTRSXP) { + PROBLEM "Argument to R_getVariantRef must be an external pointer" + ERROR; + } + + if(EXTPTR_TAG(ref) != Rf_install("VARIANTReference")) { + PROBLEM "Argument to R_getVariantRef does not have the correct tag." + ERROR; + } + + p = (VARIANT *) R_ExternalPtrAddr(ref); + return(p); +} + +SEXP +R_getDynamicVariantValue(SEXP ref) +{ + VARIANT *var; + VARTYPE rtype; + + var = R_getVariantRef(ref); + rtype = V_VT(var) & (~ VT_BYREF); + switch(rtype) { + case VT_BOOL: + return(ScalarLogical(*V_BOOLREF(var))); + break; + case VT_I4: + return(ScalarInteger(*V_I4REF(var))); + break; + case VT_R8: + return(ScalarReal(*V_R8REF(var))); + break; + default: + return(R_NilValue); + } + + return(R_NilValue); +} + + + +SEXP +R_setDynamicVariantValue(SEXP ref, SEXP val) +{ + VARIANT *var; + VARTYPE rtype; + + var = R_getVariantRef(ref); + rtype = V_VT(var) & (~ VT_BYREF); + switch(rtype) { + case VT_BOOL: + *V_BOOLREF(var) = LOGICAL(val)[0]; + break; + case VT_I4: + *V_I4REF(var) = INTEGER(val)[0]; + break; + case VT_R8: + *V_R8REF(var) = REAL(val)[0]; + break; + default: + return(R_NilValue); + } + + return(R_NilValue); +} + + +/* Taken from connect.cpp in RDCOMClient. */ + +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_ERROR: // to get errors such as #NUM as NaN in R + ans = R_scalarReal(R_NaN); + 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_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); +} + +VARTYPE +getDCOMType(SEXP obj) +{ + VARTYPE val = VT_UNKNOWN; + + switch(TYPEOF(obj)) { + case REALSXP: + val = VT_R8; + break; + case LGLSXP: + val = VT_BOOL; + break; + case INTSXP: + val = VT_I4; + break; + case STRSXP: + val = VT_BSTR; + break; + case VECSXP: + val = VT_VARIANT; + break; + default: + break; + } + + return(val); +} + +SAFEARRAY* +createRDCOMArray(SEXP obj, VARIANT *var) +{ + VARTYPE type; + unsigned int cDims = 1, len; + SAFEARRAYBOUND bounds[1]; + SAFEARRAY *arr; + void *data; + + len = Rf_length(obj); + bounds[0].lLbound = 0; + bounds[0].cElements = len; + + type = getDCOMType(obj); + arr = SafeArrayCreate(type, cDims, bounds); + + HRESULT hr = SafeArrayAccessData(arr, (void**) &data); + if(hr != S_OK) { + //std::cerr <<"Problems accessing data" << std::endl; + REprintf("Problems accessing data\n"); + SafeArrayDestroy(arr); + return(NULL); + } + + switch(TYPEOF(obj)) { + case REALSXP: + memcpy(data, REAL(obj), sizeof(double) * len); + break; + case INTSXP: + memcpy(data, INTEGER(obj), sizeof(LOGICAL(obj)[0]) * len); + break; + case LGLSXP: + for(unsigned int i = 0 ; i < len ; i++) + ((bool *) data)[i] = LOGICAL(obj)[i]; + break; + case STRSXP: + for(unsigned int i = 0 ; i < len ; i++) + ((BSTR *) data)[i] = AsBstr(getRString(obj, i)); + break; + case VECSXP: + for(unsigned int i = 0 ; i < len ; i++) { + VARIANT *v = &(((VARIANT *) data)[i]); + VariantInit(v); + R_convertRObjectToDCOM(VECTOR_ELT(obj, i), v); + } + break; + + default: + //std::cerr <<"Array case not handled yet for R type " << TYPEOF(obj) << std::endl; + REprintf("Array case not handled yet for R type %d\n", TYPEOF(obj)); + break; + } + + SafeArrayUnaccessData(arr); + + if(var) { + V_VT(var) = VT_ARRAY | type; + V_ARRAY(var) = arr; + } + + return(arr); +} + +HRESULT +createGenericCOMObject(SEXP obj, VARIANT *var) +{ + SEXP e, val; + int errorOccurred; + + /* Make certain RDCOMServer is loaded as this might be invoked + as part of RDCOMClient. */ + PROTECT(e = allocVector(LANGSXP, 3)); + SETCAR(e, Rf_install("require")); + SETCAR(CDR(e), Rf_install("RDCOMServer")); + SETCAR(CDR(CDR(e)), val = allocVector(LGLSXP, 1)); + INTEGER(val)[0] = TRUE; + SET_TAG(CDR(CDR(e)), Rf_install("quiet")); + + val = R_tryEval(e, R_GlobalEnv, &errorOccurred); + UNPROTECT(1); + if(!LOGICAL(val)[0]) { + PROBLEM "Can't attach the RDCOMServer package needed to create a generic COM object" + ERROR; + return(S_FALSE); + } + + PROTECT(e = allocVector(LANGSXP, 2)); + SETCAR(e, Rf_install("createCOMObject")); + SETCAR(CDR(e), obj); + val = R_tryEval(e, R_GlobalEnv, &errorOccurred); + if(errorOccurred) { + UNPROTECT(1); + PROBLEM "Can't create COM object" + ERROR; + return(S_FALSE); + } + + RCOMObject *robj; + if(TYPEOF(val) != EXTPTRSXP) + return(S_FALSE); + + robj = (RCOMObject *) R_ExternalPtrAddr(val); + V_VT(var) = VT_DISPATCH; + V_DISPATCH(var) = robj; + + return(S_OK); +} + +HRESULT +R_convertRObjectToDCOM(SEXP obj, VARIANT *var) +{ + HRESULT status; + int type = R_typeof(obj); + + if(!var) + return(S_FALSE); + +#ifdef RDCOM_VERBOSE + errorLog("Type of argument %d\n", type); +#endif + + if(type == EXTPTRSXP && EXTPTR_TAG(obj) == Rf_install("R_VARIANT")) { + VARIANT *tmp; + tmp = (VARIANT *) R_ExternalPtrAddr(obj); + if(tmp) { + //XXX + VariantCopy(var, tmp); + return(S_OK); + } + } + + if(ISCOMIDispatch(obj)) { + IDispatch *ptr; + ptr = (IDispatch *) derefRIDispatch(obj); + V_VT(var) = VT_DISPATCH; + V_DISPATCH(var) = ptr; + //XX + ptr->AddRef(); + return(S_OK); + } + + if(ISSInstanceOf(obj, "COMDate")) { + double val; + val = NUMERIC_DATA(GET_SLOT(obj, Rf_install(".Data")))[0]; + V_VT(var) = VT_DATE; + V_DATE(var) = val; + return(S_OK); + } else if(ISSInstanceOf(obj, "COMCurrency")) { + double val; + val = NUMERIC_DATA(GET_SLOT(obj, Rf_install(".Data")))[0]; + V_VT(var) = VT_R8; + V_R8(var) = val; + VariantChangeType(var, var, 0, VT_CY); + return(S_OK); + } else if(ISSInstanceOf(obj, "COMDecimal")) { + double val; + val = NUMERIC_DATA(GET_SLOT(obj, Rf_install(".Data")))[0]; + V_VT(var) = VT_R8; + V_R8(var) = val; + VariantChangeType(var, var, 0, VT_DECIMAL); + return(S_OK); + } + + + /* We have a complex object and we are not going to try to convert it directly + but instead create an COM server object to represent it to the outside world. */ + if((type == VECSXP && Rf_length(GET_NAMES(obj))) || Rf_length(GET_CLASS(obj)) > 0 || isMatrix(obj)) { + status = createGenericCOMObject(obj, var); + if(status == S_OK) + return(S_OK); + } + + if(Rf_length(obj) == 0) { + V_VT(var) = VT_VOID; + return(S_OK); + } + + if(type == VECSXP || Rf_length(obj) > 1) { + createRDCOMArray(obj, var); + return(S_OK); + } + + switch(type) { + case STRSXP: + V_VT(var) = VT_BSTR; + V_BSTR(var) = AsBstr(getRString(obj, 0)); + break; + + case INTSXP: + V_VT(var) = VT_I4; + V_I4(var) = R_integerScalarValue(obj, 0); + break; + + case REALSXP: + V_VT(var) = VT_R8; + V_R8(var) = R_realScalarValue(obj, 0); + break; + + case LGLSXP: + V_VT(var) = VT_BOOL; + V_BOOL(var) = R_logicalScalarValue(obj, 0) ? VARIANT_TRUE : VARIANT_FALSE; + break; + + case VECSXP: + break; + } + + return(S_OK); +} + +extern "C" { + void registerCOMObject(void *, int); +} + +void +RDCOM_finalizer(SEXP s) +{ + IUnknown *ptr = (IUnknown*) derefRDCOMPointer(s); + if(ptr) { +#ifdef ANNOUNCE_COM_CALLS + fprintf(stderr, "Releasing COM object %p\n", ptr);fflush(stderr); +#endif + +#ifdef REGISTER_COM_OBJECTS_WITH_S + registerCOMObject(ptr, 0); +#endif + + //XXX + ptr->Release(); +#ifdef ANNOUNCE_COM_CALLS + fprintf(stderr, "Released COM object %p\n", ptr);fflush(stderr); +#endif + R_ClearExternalPtr(s); + } +} + +void +RDCOM_SafeArray_finalizer(SEXP s) +{ + SAFEARRAY *arr; + arr = (SAFEARRAY*) R_ExternalPtrAddr(s); + if(arr) { + SafeArrayDestroy(arr); + R_ClearExternalPtr(s); + } +} + +SEXP +R_create2DArray(SEXP obj) +{ + SAFEARRAYBOUND bounds[2] = {{0, 0}, {0, 0}};; + SAFEARRAY *arr; + void *data, *el; + VARTYPE type = VT_R8; + SEXP dim = GET_DIM(obj); + int integer; + double real; + BSTR bstr; + + + bounds[0].cElements = INTEGER(dim)[0]; + bounds[1].cElements = INTEGER(dim)[1]; + + type = getDCOMType(obj); + + arr = SafeArrayCreate(type, 2, bounds); + SafeArrayAccessData(arr, (void**) &data); + + long indices[2]; + UINT i, j, ctr = 0; + for(j = 0 ; j < bounds[1].cElements; j++) { + indices[1] = j; + for(i = 0; i < bounds[0].cElements; i++, ctr++) { + indices[0] = i; + switch(TYPEOF(obj)) { + case LGLSXP: + integer = (LOGICAL(obj)[ctr] ? 1:0); + el = &integer; + break; + case REALSXP: + real = REAL(obj)[ctr]; + el = ℜ + break; + case INTSXP: + integer = INTEGER(obj)[ctr]; + el = &integer; + break; + case STRSXP: + bstr = AsBstr(CHAR(STRING_ELT(obj, ctr))); + el = (void*) bstr; + break; + default: + continue; + break; + } + + SafeArrayPutElement(arr, indices, el); + } + } + SafeArrayUnaccessData(arr); + + VARIANT *var; + var = (VARIANT*) malloc(sizeof(VARIANT)); + VariantInit(var); + V_VT(var) = VT_ARRAY | type; + V_ARRAY(var) = arr; + + SEXP ans; + PROTECT(ans = R_MakeExternalPtr((void*) var, Rf_install("R_VARIANT"), R_NilValue)); + R_RegisterCFinalizer(ans, RDCOM_SafeArray_finalizer); + UNPROTECT(1); + return(ans); +} + +extern "C" +SEXP +R_createVariant(SEXP type) +{ + VARIANT var; + VariantInit(&var); + return(createRVariantObject(&var, INTEGER_DATA(type)[0])); +} + + +SEXP +R_setVariant(SEXP svar, SEXP value, SEXP type) +{ + VARIANT *var; + var = (VARIANT *)R_ExternalPtrAddr(GET_SLOT(svar, Rf_install("ref"))); + if(!var) { + PROBLEM "Null VARIANT value passed to R_setVariant. Was this saved in another session\n" + ERROR; + } + + HRESULT hr; + hr = R_convertRObjectToDCOM(value, var); + + SEXP ans; + ans = NEW_LOGICAL(1); + LOGICAL_DATA(ans)[0] = hr == S_OK ? TRUE : FALSE; + return(ans); +} + + diff --git a/src/converters.h b/src/converters.h index a465019..77cb219 100644 --- a/src/converters.h +++ b/src/converters.h @@ -1,14 +1,14 @@ - -HRESULT R_convertRObjectToDCOM(SEXP obj, VARIANT *var); -SEXP R_convertDCOMObjectToR(VARIANT *var); -char *FromBstr(BSTR str); -BSTR AsBstr(const char *str); -SEXP getArray(SAFEARRAY *arr, int dimNo, int numDims, long *indices); - -extern "C" { - void RDCOM_finalizer(SEXP s); - SEXP R_create2DArray(SEXP obj); - SEXP R_createVariant(SEXP type); - SEXP R_setVariant(SEXP svar, SEXP value, SEXP type); -} - + +HRESULT R_convertRObjectToDCOM(SEXP obj, VARIANT *var); +SEXP R_convertDCOMObjectToR(VARIANT *var); +char *FromBstr(BSTR str); +BSTR AsBstr(const char *str); +SEXP getArray(SAFEARRAY *arr, int dimNo, int numDims, long *indices); + +extern "C" { + void RDCOM_finalizer(SEXP s); + SEXP R_create2DArray(SEXP obj); + SEXP R_createVariant(SEXP type); + SEXP R_setVariant(SEXP svar, SEXP value, SEXP type); +} +