/* OLE.xs
*
* (c) 1995 Microsoft Corporation. All rights reserved.
* Developed by ActiveWare Internet Corp., now known as
* ActiveState Tool Corp., http://www.ActiveState.com
*
* Other modifications Copyright (c) 1997-1999 by Gurusamy Sarathy
* <gsar@ActiveState.com> and Jan Dubois <jand@ActiveState.com>
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*
*
* File contents:
*
* - C helper routines
* - Package Win32::OLE Constructor and method invocation
* - Package Win32::OLE::Tie Implements properties as tied hash
* - Package Win32::OLE::Const Load application constants from type library
* - Package Win32::OLE::Enum OLE collection enumeration
* - Package Win32::OLE::Variant Implements Perl VARIANT objects
* - Package Win32::OLE::NLS National Language Support
* - Package Win32::OLE::TypeLib Type library access
* - Package Win32::OLE::TypeInfo Type info access
*
*/
#ifdef __GNUC__
# pragma GCC diagnostic ignored "-Wwrite-strings"
#endif
// #define _DEBUG
#define register /* be gone */
#define MY_VERSION "Win32::OLE(" XS_VERSION ")"
#include <math.h> /* this hack gets around VC-5.0 brainmelt */
#define _WIN32_DCOM
#include <windows.h>
#include <ocidl.h>
#ifdef _DEBUG
# include <crtdbg.h>
# define DEBUGBREAK _CrtDbgBreak()
#else
# define DEBUGBREAK
#endif
// MingW is missing these 2 macros
#ifndef V_RECORD
# ifdef NONAMELESSUNION
# define V_RECORDINFO(X) ((X)->__VARIANT_NAME_1.__VARIANT_NAME_2.__VARIANT_NAME_3.__VARIANT_NAME_4.pRecInfo)
# define V_RECORD(X) ((X)->__VARIANT_NAME_1.__VARIANT_NAME_2.__VARIANT_NAME_3.__VARIANT_NAME_4.pvRecord)
# else
# define V_RECORDINFO(X) ((X)->pRecInfo)
# define V_RECORD(X) ((X)->pvRecord)
# endif
#endif
extern "C" {
#ifndef GUIDKIND_DEFAULT_SOURCE_DISP_IID
# define GUIDKIND_DEFAULT_SOURCE_DISP_IID 1
#endif
#ifdef __CYGWIN__
# undef WIN32 /* don't use with Cygwin & Perl */
# include <netdb.h>
# include <sys/socket.h>
# include <unistd.h>
# ifndef strrev
# define strrev my_strrev
static char *
my_strrev(char *str)
{
char *left = str;
char *right = left + strlen(left) - 1;
while (left < right) {
char temp = *left;
*left++ = *right;
*right-- = temp;
}
return str;
}
# endif /* strrev */
#endif
#define PERL_NO_GET_CONTEXT
#define NO_XSLOCKS
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "patchlevel.h"
#undef WORD
typedef unsigned short WORD;
#ifndef _WIN64
# define DWORD_PTR DWORD
#endif
#if PERL_VERSION < 6
# error Win32::OLE requires Perl 5.6.0 or later
#endif
#ifdef USE_5005THREADS
# error Win32::OLE is incompatible with 5.005 style threads
#endif
#if PERL_VERSION > 6
# define my_utf8_to_uv(s) utf8_to_uvuni(s, NULL)
#else
# if PERL_SUBVERSION > 0
# define my_utf8_to_uv(s) utf8_to_uv_simple(s, NULL)
# else
# define my_utf8_to_uv(s) utf8_to_uv(s, NULL)
# endif
#endif
#ifndef _DEBUG
# define DBG(a)
#else
# define DBG(a) MyDebug a
void
MyDebug(const char *pat, ...)
{
DWORD thread = GetCurrentThreadId();
void *context = PERL_GET_CONTEXT;
char szBuffer[512];
char *szMessage = szBuffer + sprintf(szBuffer, "[%d:%p] ", thread, context);
va_list args;
va_start(args, pat);
vsprintf(szMessage, pat, args);
OutputDebugString(szBuffer);
va_end(args);
}
#endif
/* constants */
static const DWORD WINOLE_MAGIC = 0x12344321;
static const DWORD WINOLEENUM_MAGIC = 0x12344322;
static const DWORD WINOLEVARIANT_MAGIC = 0x12344323;
static const DWORD WINOLETYPELIB_MAGIC = 0x12344324;
static const DWORD WINOLETYPEINFO_MAGIC = 0x12344325;
static const LCID lcidSystemDefault = 2 << 10;
/* static const LCID lcidDefault = 0; language neutral */
static const LCID lcidDefault = lcidSystemDefault;
static const UINT cpDefault = CP_ACP;
static const BOOL varDefault = FALSE;
static char PERL_OLE_ID[] = "___Perl___OleObject___";
static const int PERL_OLE_IDLEN = sizeof(PERL_OLE_ID)-1;
static const int OLE_BUF_SIZ = 256;
/* class names */
static char szUNICODESTRING[] = "Unicode::String";
static char szWINOLE[] = "Win32::OLE";
static char szWINOLEENUM[] = "Win32::OLE::Enum";
static char szWINOLEVARIANT[] = "Win32::OLE::Variant";
static char szWINOLETIE[] = "Win32::OLE::Tie";
static char szWINOLETYPELIB[] = "Win32::OLE::TypeLib";
static char szWINOLETYPEINFO[] = "Win32::OLE::TypeInfo";
/* class variable names */
static char LCID_NAME[] = "LCID";
static const int LCID_LEN = sizeof(LCID_NAME)-1;
static char CP_NAME[] = "CP";
static const int CP_LEN = sizeof(CP_NAME)-1;
static char VAR_NAME[] = "Variant";
static const int VAR_LEN = sizeof(VAR_NAME)-1;
static char WARN_NAME[] = "Warn";
static const int WARN_LEN = sizeof(WARN_NAME)-1;
static char _NEWENUM_NAME[] = "_NewEnum";
static const int _NEWENUM_LEN = sizeof(_NEWENUM_NAME)-1;
static char _UNIQUE_NAME[] = "_Unique";
static const int _UNIQUE_LEN = sizeof(_UNIQUE_NAME)-1;
static char LASTERR_NAME[] = "LastError";
static const int LASTERR_LEN = sizeof(LASTERR_NAME)-1;
static char TIE_NAME[] = "Tie";
static const int TIE_LEN = sizeof(TIE_NAME)-1;
#define COINIT_OLEINITIALIZE -1
#define COINIT_NO_INITIALIZE -2
typedef HRESULT (STDAPICALLTYPE FNCOINITIALIZEEX)(LPVOID, DWORD);
typedef void (STDAPICALLTYPE FNCOUNINITIALIZE)(void);
typedef HRESULT (STDAPICALLTYPE FNCOCREATEINSTANCEEX)
(REFCLSID, IUnknown*, DWORD, COSERVERINFO*, DWORD, MULTI_QI*);
typedef HWND (WINAPI FNHTMLHELP)(HWND hwndCaller, LPCSTR pszFile,
UINT uCommand, DWORD dwData);
typedef struct _tagOBJECTHEADER OBJECTHEADER;
/* per interpreter variables */
typedef struct
{
CRITICAL_SECTION CriticalSection;
OBJECTHEADER *pObj;
BOOL bInitialized;
HV *hv_unique;
/* DCOM function addresses are resolved dynamically */
HINSTANCE hOLE32;
FNCOINITIALIZEEX *pfnCoInitializeEx;
FNCOUNINITIALIZE *pfnCoUninitialize;
FNCOCREATEINSTANCEEX *pfnCoCreateInstanceEx;
/* HTML Help Control loaded dynamically */
HINSTANCE hHHCTRL;
FNHTMLHELP *pfnHtmlHelp;
} PERINTERP;
#ifdef PERL_IMPLICIT_CONTEXT
# define dPERINTERP \
SV **pinterp = hv_fetch(PL_modglobal, MY_VERSION, \
sizeof(MY_VERSION)-1, FALSE); \
if (!pinterp || !*pinterp || !SvIOK(*pinterp)) \
warn(MY_VERSION ": Per-interpreter data not initialized"); \
PERINTERP *pInterp = INT2PTR(PERINTERP*, SvIV(*pinterp))
# define INTERP pInterp
#else
static PERINTERP Interp;
# define dPERINTERP extern int errno
# define INTERP (&Interp)
#endif
#define g_pObj (INTERP->pObj)
#define g_bInitialized (INTERP->bInitialized)
#define g_CriticalSection (INTERP->CriticalSection)
#define g_hv_unique (INTERP->hv_unique)
#define g_hOLE32 (INTERP->hOLE32)
#define g_pfnCoInitializeEx (INTERP->pfnCoInitializeEx)
#define g_pfnCoUninitialize (INTERP->pfnCoUninitialize)
#define g_pfnCoCreateInstanceEx (INTERP->pfnCoCreateInstanceEx)
#define g_hHHCTRL (INTERP->hHHCTRL)
#define g_pfnHtmlHelp (INTERP->pfnHtmlHelp)
/* common object header */
typedef struct _tagOBJECTHEADER
{
long lMagic;
OBJECTHEADER *pNext;
OBJECTHEADER *pPrevious;
#ifdef PERL_IMPLICIT_CONTEXT
PERINTERP *pInterp;
#endif
} OBJECTHEADER;
#define OBJFLAG_DESTROYED 0x01
#define OBJFLAG_UNIQUE 0x02
/* Win32::OLE object */
class EventSink;
typedef struct
{
OBJECTHEADER header;
UV flags;
IDispatch *pDispatch;
ITypeInfo *pTypeInfo;
IEnumVARIANT *pEnum;
EventSink *pEventSink;
HV *self;
HV *hashTable;
SV *destroy;
unsigned short cFuncs;
unsigned short cVars;
unsigned int PropIndex;
} WINOLEOBJECT;
/* Win32::OLE::Enum object */
typedef struct
{
OBJECTHEADER header;
IEnumVARIANT *pEnum;
} WINOLEENUMOBJECT;
/* Win32::OLE::Variant object */
typedef struct
{
OBJECTHEADER header;
VARIANT variant;
VARIANT byref;
} WINOLEVARIANTOBJECT;
/* Win32::OLE::TypeLib object */
typedef struct
{
OBJECTHEADER header;
ITypeLib *pTypeLib;
TLIBATTR *pTLibAttr;
} WINOLETYPELIBOBJECT;
/* Win32::OLE::TypeInfo object */
typedef struct
{
OBJECTHEADER header;
ITypeInfo *pTypeInfo;
TYPEATTR *pTypeAttr;
} WINOLETYPEINFOOBJECT;
/* EventSink class */
class EventSink : public IDispatch
{
public:
// IUnknown methods
STDMETHOD(QueryInterface)(REFIID riid, LPVOID *ppvObj);
STDMETHOD_(ULONG, AddRef)(void);
STDMETHOD_(ULONG, Release)(void);
// IDispatch methods
STDMETHOD(GetTypeInfoCount)(UINT *pctinfo);
STDMETHOD(GetTypeInfo)(
UINT itinfo,
LCID lcid,
ITypeInfo **pptinfo);
STDMETHOD(GetIDsOfNames)(
REFIID riid,
OLECHAR **rgszNames,
UINT cNames,
LCID lcid,
DISPID *rgdispid);
STDMETHOD(Invoke)(
DISPID dispidMember,
REFIID riid,
LCID lcid,
WORD wFlags,
DISPPARAMS *pdispparams,
VARIANT *pvarResult,
EXCEPINFO *pexcepinfo,
UINT *puArgErr);
EventSink(pTHX_ WINOLEOBJECT *pObj, SV *events,
REFIID riid, ITypeInfo *pTypeInfo);
~EventSink(void);
HRESULT Advise(IConnectionPoint *pConnectionPoint);
void Unadvise(void);
private:
int m_refcount;
WINOLEOBJECT *m_pObj;
IConnectionPoint *m_pConnectionPoint;
DWORD m_dwCookie;
SV *m_events;
IID m_iid;
ITypeInfo *m_pTypeInfo;
#ifdef PERL_IMPLICIT_CONTEXT
pTHX;
#endif
};
/* Forwarder class */
class Forwarder : public IDispatch
{
public:
// IUnknown methods
STDMETHOD(QueryInterface)(REFIID riid, LPVOID *ppvObj);
STDMETHOD_(ULONG, AddRef)(void);
STDMETHOD_(ULONG, Release)(void);
// IDispatch methods
STDMETHOD(GetTypeInfoCount)(UINT *pctinfo);
STDMETHOD(GetTypeInfo)(
UINT itinfo,
LCID lcid,
ITypeInfo **pptinfo);
STDMETHOD(GetIDsOfNames)(
REFIID riid,
OLECHAR **rgszNames,
UINT cNames,
LCID lcid,
DISPID *rgdispid);
STDMETHOD(Invoke)(
DISPID dispidMember,
REFIID riid,
LCID lcid,
WORD wFlags,
DISPPARAMS *pdispparams,
VARIANT *pvarResult,
EXCEPINFO *pexcepinfo,
UINT *puArgErr);
Forwarder(pTHX_ HV *stash, SV *method);
~Forwarder(void);
private:
int m_refcount;
HV *m_stash;
SV *m_method;
#ifdef PERL_IMPLICIT_CONTEXT
pTHX;
#endif
};
/* forward declarations */
HRESULT SetSVFromVariantEx(pTHX_ VARIANTARG *pVariant, SV* sv, HV *stash,
BOOL bByRefObj=FALSE);
HRESULT SetVariantFromSVEx(pTHX_ SV* sv, VARIANT *pVariant, UINT cp,
LCID lcid);
HRESULT AssignVariantFromSV(pTHX_ SV* sv, VARIANT *pVariant,
UINT cp, LCID lcid);
//------------------------------------------------------------------------
void
MagicGet(pTHX_ SV *sv)
{
if (SvGMAGICAL(sv)) {
mg_get(sv);
// If the sv has lvalue magic (e.g. substr), it will stay magical
// and mg_get() will *not* set the public flags. We try to work
// around this here for at least the "substr" and "vec" cases.
//
// Setting the public POK flag should be safe because this function
// is only called on function arguments, which will be discarded
// once the function returns.
if (SvGMAGICAL(sv) && SvPOKp(sv))
SvPOK_on(sv);
}
}
BOOL
StartsWithAlpha(pTHX_ SV *sv)
{
char *str = SvPV_nolen(sv);
if (SvUTF8(sv))
return isALPHA_uni(my_utf8_to_uv((U8*)str));
else
return isALPHA(*str);
}
inline void
SpinMessageLoop(void)
{
MSG msg;
DBG(("SpinMessageLoop\n"));
while (PeekMessage(&msg, NULL, 0, 0, PM_REMOVE)) {
TranslateMessage(&msg);
DispatchMessage(&msg);
}
} /* SpinMessageLoop */
BOOL
IsLocalMachine(pTHX_ SV *host)
{
char szComputerName[MAX_COMPUTERNAME_LENGTH+1];
DWORD dwSize = sizeof(szComputerName);
char *pszMachine = SvPV_nolen(host);
char *pszName = pszMachine;
while (*pszName == '\\')
++pszName;
if (*pszName == '\0')
return TRUE;
/* Check against local computer name (from registry) */
if (GetComputerNameA(szComputerName, &dwSize)
&& stricmp(pszName, szComputerName) == 0)
{
return TRUE;
}
/* gethostname(), gethostbyname() and inet_addr() all call proxy functions
* in the Perl socket layer wrapper in win32sck.c. Therefore calling
* WSAStartup() here is not necessary.
*/
/* Determine main host name of local machine */
char szBuffer[200];
if (gethostname(szBuffer, sizeof(szBuffer)) != 0)
return FALSE;
/* Copy list of addresses for local machine */
struct hostent *pHostEnt = gethostbyname(szBuffer);
if (!pHostEnt)
return FALSE;
if (pHostEnt->h_addrtype != PF_INET || pHostEnt->h_length != 4) {
warn(MY_VERSION ": IsLocalMachine() gethostbyname failure");
return FALSE;
}
int index;
int count = 0;
char *pLocal;
while (pHostEnt->h_addr_list[count])
++count;
New(0, pLocal, 4*count, char);
for (index = 0; index < count; ++index)
memcpy(pLocal+4*index, pHostEnt->h_addr_list[index], 4);
/* Determine addresses of remote machine */
unsigned long ulRemoteAddr;
char *pRemote[2] = {NULL, NULL};
char **ppRemote = &pRemote[0];
if (isdigit(*pszMachine)) {
/* Convert numeric dotted address */
ulRemoteAddr = inet_addr(pszMachine);
if (ulRemoteAddr != INADDR_NONE)
pRemote[0] = (char*)&ulRemoteAddr;
}
else {
/* Lookup addresses for remote host name */
pHostEnt = gethostbyname(pszMachine);
if (pHostEnt)
if (pHostEnt->h_addrtype == PF_INET && pHostEnt->h_length == 4)
ppRemote = pHostEnt->h_addr_list;
}
/* Compare list of addresses of remote machine against local addresses */
while (*ppRemote) {
for (index = 0; index < count; ++index)
if (memcmp(pLocal+4*index, *ppRemote, 4) == 0) {
Safefree(pLocal);
return TRUE;
}
++ppRemote;
}
Safefree(pLocal);
return FALSE;
} /* IsLocalMachine */
HRESULT
CLSIDFromRemoteRegistry(pTHX_ SV *host, SV *progid, CLSID *pCLSID)
{
HKEY hKeyLocalMachine;
HKEY hKeyProgID;
LONG err;
HRESULT hr = S_OK;
err = RegConnectRegistryA(SvPV_nolen(host), HKEY_LOCAL_MACHINE, &hKeyLocalMachine);
if (err != ERROR_SUCCESS)
return HRESULT_FROM_WIN32(err);
SV *subkey = sv_2mortal(newSVpv("SOFTWARE\\Classes\\", 0));
sv_catsv(subkey, progid);
sv_catpv(subkey, "\\CLSID");
err = RegOpenKeyExA(hKeyLocalMachine, SvPV_nolen(subkey), 0, KEY_READ,
&hKeyProgID);
if (err != ERROR_SUCCESS)
hr = HRESULT_FROM_WIN32(err);
else {
DWORD dwType;
char szCLSID[100];
DWORD dwLength = sizeof(szCLSID);
err = RegQueryValueEx(hKeyProgID, "", NULL, &dwType,
(unsigned char*)&szCLSID, &dwLength);
if (err != ERROR_SUCCESS)
hr = HRESULT_FROM_WIN32(err);
else if (dwType == REG_SZ) {
OLECHAR wszCLSID[sizeof(szCLSID)];
MultiByteToWideChar(CP_ACP, 0, szCLSID, -1,
wszCLSID, sizeof(szCLSID));
hr = CLSIDFromString(wszCLSID, pCLSID);
}
else /* XXX maybe there is a more appropriate error code? */
hr = HRESULT_FROM_WIN32(ERROR_CANTREAD);
RegCloseKey(hKeyProgID);
}
RegCloseKey(hKeyLocalMachine);
return hr;
} /* CLSIDFromRemoteRegistry */
/* The following strategy is used to avoid the limitations of hardcoded
* buffer sizes: Conversion between wide char and multibyte strings
* is performed by GetMultiByte and GetWideChar respectively. The
* caller passes a default buffer and size. If the buffer is too small
* then the conversion routine allocates a new buffer that is big enough.
* The caller must free this buffer using the ReleaseBuffer function. */
inline void
ReleaseBuffer(pTHX_ void *pszHeap, void *pszStack)
{
if (pszHeap != pszStack && pszHeap)
Safefree(pszHeap);
}
char *
GetMultiByteEx(pTHX_ OLECHAR *wide, int *pcch, char *psz, int len, UINT cp)
{
int count;
if (psz) {
if (!wide || !*pcch) {
fail:
*psz = (char)0;
*pcch = 0;
return psz;
}
count = WideCharToMultiByte(cp, 0, wide, *pcch, psz, len, NULL, NULL);
if (count > 0)
goto succeed;
}
else if (!wide || !*pcch) {
Newz(0, psz, 1, char);
*pcch = 0;
return psz;
}
count = WideCharToMultiByte(cp, 0, wide, *pcch, NULL, 0, NULL, NULL);
if (count == 0) { /* should never happen */
warn(MY_VERSION ": GetMultiByte() failure: %lu", GetLastError());
DEBUGBREAK;
if (!psz)
New(0, psz, 1, char);
goto fail;
}
Newz(0, psz, count, char);
WideCharToMultiByte(cp, 0, wide, *pcch, psz, count, NULL, NULL);
succeed:
if (*pcch == -1)
*pcch = count - 1; /* because count includes the trailing '\0' */
else
*pcch = count;
return psz;
} /* GetMultiByteEx */
char *
GetMultiByte(pTHX_ OLECHAR *wide, char *psz, int len, UINT cp)
{
int cch = -1;
return GetMultiByteEx(aTHX_ wide, &cch, psz, len, cp);
}
SV *
sv_setbstr(pTHX_ SV *sv, BSTR bstr, UINT cp)
{
if (!bstr) {
if (sv)
sv_setpvn(sv, "", 0);
else
sv = newSVpvn("", 0);
return sv;
}
int len = WideCharToMultiByte(cp, 0, bstr, SysStringLen(bstr),
NULL, 0, NULL, NULL);
if (sv)
sv_grow(sv, len+1);
else
sv = newSV(len+1);
WideCharToMultiByte(cp, 0, bstr, SysStringLen(bstr),
SvPVX(sv), len, NULL, NULL);
SvPOK_on(sv);
SvPVX(sv)[len] = '\0';
SvCUR_set(sv, len);
if (cp == CP_UTF8) {
SvUTF8_on(sv);
sv_utf8_downgrade(sv, TRUE);
}
return sv;
}
OLECHAR *
GetWideChar(pTHX_ SV *sv, OLECHAR *wide, int len, UINT cp)
{
/* Note: len is number of OLECHARs, not bytes! */
int count;
STRLEN strlen;
char *str = NULL;
if (sv) {
str = SvPV(sv, strlen);
++strlen; // include trailing '\0' character
if (cp == CP_UTF8 && !SvUTF8(sv))
cp = CP_ACP;
}
if (wide) {
if (!str) {
*wide = (OLECHAR) 0;
return wide;
}
count = MultiByteToWideChar(cp, 0, str, (int)strlen, wide, len);
if (count > 0)
return wide;
}
else if (!str) {
Newz(0, wide, 1, OLECHAR);
return wide;
}
count = MultiByteToWideChar(cp, 0, str, (int)strlen, NULL, 0);
if (count == 0) {
warn(MY_VERSION ": GetWideChar() failure: %lu", GetLastError());
DEBUGBREAK;
if (!wide)
New(0, wide, 1, OLECHAR);
*wide = (OLECHAR) 0;
return wide;
}
Newz(0, wide, count, OLECHAR);
MultiByteToWideChar(cp, 0, str, (int)strlen, wide, count);
return wide;
} /* GetWideChar */
HV *
GetStash(pTHX_ SV *sv)
{
if (sv_isobject(sv))
return SvSTASH(SvRV(sv));
else if (SvPOK(sv))
return gv_stashsv(sv, TRUE);
else
return (HV*)&PL_sv_undef;
} /* GetStash */
HV *
GetWin32OleStash(pTHX_ SV *sv)
{
SV *pkg;
if (sv_isobject(sv))
pkg = newSVpv(HvNAME(SvSTASH(SvRV(sv))), 0);
else if (SvPOK(sv))
pkg = newSVpv(SvPVX(sv), SvCUR(sv));
else
pkg = newSVpv(szWINOLE, 0); /* should never happen */
char *pszColon = strrchr(SvPVX(pkg), ':');
if (pszColon) {
--pszColon;
while (pszColon > SvPVX(pkg) && *pszColon == ':')
--pszColon;
SvCUR_set(pkg, pszColon - SvPVX(pkg) + 1);
SvPVX(pkg)[SvCUR(pkg)] = '\0';
}
HV *stash = gv_stashsv(pkg, TRUE);
SvREFCNT_dec(pkg);
return stash;
} /* GetWin32OleStash */
IV
QueryPkgVar(pTHX_ HV *stash, char *var, STRLEN len, IV def=0)
{
SV *sv;
GV **gv = (GV**)hv_fetch(stash, var, (I32)len, FALSE);
if (gv && (sv = GvSV(*gv)) != NULL && SvIOK(sv)) {
DBG(("QueryPkgVar(%s::%s) returns %d\n", HvNAME(stash), var, SvIV(sv)));
return SvIV(sv);
}
DBG(("QueryPkgVar(%s::%s) default %d\n", HvNAME(stash), var, def));
return def;
}
void
SetLastOleError(pTHX_ HV *stash, HRESULT hr=S_OK, char *pszMsg=NULL)
{
/* Find $Win32::OLE::LastError */
SV *sv = sv_2mortal(newSVpv(HvNAME(stash), 0));
sv_catpvn(sv, "::", 2);
sv_catpvn(sv, LASTERR_NAME, LASTERR_LEN);
SV *lasterr = perl_get_sv(SvPV_nolen(sv), TRUE);
if (!lasterr) {
warn(MY_VERSION ": SetLastOleError: couldnot create variable %s",
LASTERR_NAME);
DEBUGBREAK;
return;
}
sv_setiv(lasterr, (IV)hr);
if (pszMsg) {
sv_setpv(lasterr, pszMsg);
SvIOK_on(lasterr);
}
}
void
ReportOleError(pTHX_ HV *stash, HRESULT hr, EXCEPINFO *pExcep=NULL,
SV *svAdd=NULL)
{
dSP;
SV *sv;
IV warnlvl = QueryPkgVar(aTHX_ stash, WARN_NAME, WARN_LEN);
GV **pgv = (GV**)hv_fetch(stash, WARN_NAME, WARN_LEN, FALSE);
CV *cv = Nullcv;
if (pgv && (sv = GvSV(*pgv)) && SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)
cv = (CV*)sv;
sv = sv_2mortal(newSV(200));
SvPOK_on(sv);
/* start with exception info */
if (pExcep && (pExcep->bstrSource || pExcep->bstrDescription)) {
char szSource[80] = "<Unknown Source>";
char szDesc[200] = "<No description provided>";
char *pszSource = szSource;
char *pszDesc = szDesc;
UINT cp = (UINT)QueryPkgVar(aTHX_ stash, CP_NAME, CP_LEN, cpDefault);
if (pExcep->bstrSource)
pszSource = GetMultiByte(aTHX_ pExcep->bstrSource,
szSource, sizeof(szSource), cp);
if (pExcep->bstrDescription)
pszDesc = GetMultiByte(aTHX_ pExcep->bstrDescription,
szDesc, sizeof(szDesc), cp);
sv_setpvf(sv, "OLE exception from \"%s\":\n\n%s\n\n",
pszSource, pszDesc);
ReleaseBuffer(aTHX_ pszSource, szSource);
ReleaseBuffer(aTHX_ pszDesc, szDesc);
/* SysFreeString accepts NULL too */
SysFreeString(pExcep->bstrSource);
SysFreeString(pExcep->bstrDescription);
SysFreeString(pExcep->bstrHelpFile);
}
/* always include OLE error code */
sv_catpvf(sv, MY_VERSION " error 0x%08x", hr);
/* try to append ': "error text"' from message catalog */
char *pszMsgText;
DWORD dwCount;
dwCount = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER |
FORMAT_MESSAGE_FROM_SYSTEM |
FORMAT_MESSAGE_IGNORE_INSERTS,
NULL, hr, lcidSystemDefault,
(LPSTR)&pszMsgText, 0, NULL);
if (dwCount > 0) {
sv_catpv(sv, ": \"");
/* remove trailing dots and CRs/LFs from message */
while (dwCount > 0 &&
(pszMsgText[dwCount-1] < ' ' || pszMsgText[dwCount-1] == '.'))
pszMsgText[--dwCount] = '\0';
/* skip carriage returns in message text */
char *psz = pszMsgText;
char *pCR;
while ((pCR = strchr(psz, '\r')) != NULL) {
sv_catpvn(sv, psz, pCR-psz);
psz = pCR+1;
}
if (*psz != '\0')
sv_catpv(sv, psz);
sv_catpv(sv, "\"");
LocalFree(pszMsgText);
}
/* add additional error details */
if (svAdd) {
sv_catpv(sv, "\n ");
sv_catsv(sv, svAdd);
}
/* try to keep linelength of description below 80 chars. */
char *pLastBlank = NULL;
char *pch = SvPVX(sv);
int cch;
for (cch = 0; *pch; ++pch, ++cch) {
if (*pch == ' ') {
pLastBlank = pch;
}
else if (*pch == '\n') {
pLastBlank = pch;
cch = 0;
}
if (cch > 76 && pLastBlank) {
*pLastBlank = '\n';
cch = (int)(pch - pLastBlank);
}
}
SetLastOleError(aTHX_ stash, hr, SvPVX(sv));
DBG(("ReportOleError: hr=0x%08x warnlvl=%d\n%s", hr, warnlvl, SvPVX(sv)));
if (!cv && (warnlvl > 1 || (warnlvl == 1 && (PL_dowarn & G_WARN_ON)))) {
if (warnlvl < 3) {
cv = perl_get_cv("Carp::carp", FALSE);
if (!cv)
warn(SvPVX(sv));
}
else {
cv = perl_get_cv("Carp::croak", FALSE);
if (!cv)
croak(SvPVX(sv));
}
}
if (cv) {
ENTER;
SAVETMPS;
PUSHMARK(sp);
XPUSHs(sv);
PUTBACK;
perl_call_sv((SV*)cv, G_DISCARD|G_EVAL);
FREETMPS;
LEAVE;
if (SvTRUE(ERRSV)) {
#if defined(ACTIVEPERL_CHANGELIST) || (PERL_VERSION > 6 || PERL_SUBVERSION > 0)
if (sv_isobject(ERRSV))
croak(Nullch); /* rethrow exception */
else
croak("%s", SvPV_nolen(ERRSV));
#else
croak("%s", SvPV_nolen(ERRSV));
#endif
}
}
} /* ReportOleError */
inline BOOL
CheckOleError(pTHX_ HV *stash, HRESULT hr, EXCEPINFO *pExcep=NULL,
SV *svAdd=NULL)
{
if (FAILED(hr)) {
ReportOleError(aTHX_ stash, hr, pExcep, svAdd);
return TRUE;
}
return FALSE;
}
SV *
CheckDestroyFunction(pTHX_ SV *sv, char *szMethod)
{
/* undef */
if (!SvOK(sv))
return NULL;
/* method name or CODE ref */
if (SvPOK(sv) || (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV))
return sv;
warn("%s(): DESTROY must be a method name or a CODE reference", szMethod);
DEBUGBREAK;
return NULL;
}
void
AddToObjectChain(pTHX_ OBJECTHEADER *pHeader, long lMagic)
{
dPERINTERP;
DBG(("AddToObjectChain(0x%08x) lMagic=0x%08x", pHeader, lMagic));
EnterCriticalSection(&g_CriticalSection);
pHeader->lMagic = lMagic;
pHeader->pPrevious = NULL;
pHeader->pNext = g_pObj;
#ifdef PERL_IMPLICIT_CONTEXT
pHeader->pInterp = INTERP;
#endif
if (g_pObj)
g_pObj->pPrevious = pHeader;
g_pObj = pHeader;
LeaveCriticalSection(&g_CriticalSection);
}
void
RemoveFromObjectChain(pTHX_ OBJECTHEADER *pHeader)
{
DBG(("RemoveFromObjectChain(0x%08x) lMagic=0x%08x\n", pHeader,
pHeader ? pHeader->lMagic : 0));
if (!pHeader)
return;
#ifdef PERL_IMPLICIT_CONTEXT
PERINTERP *pInterp = pHeader->pInterp;
#endif
EnterCriticalSection(&g_CriticalSection);
if (!pHeader->pPrevious) {
g_pObj = pHeader->pNext;
if (g_pObj)
g_pObj->pPrevious = NULL;
}
else if (!pHeader->pNext)
pHeader->pPrevious->pNext = NULL;
else {
pHeader->pPrevious->pNext = pHeader->pNext;
pHeader->pNext->pPrevious = pHeader->pPrevious;
}
pHeader->lMagic = 0;
LeaveCriticalSection(&g_CriticalSection);
}
SV *
CreatePerlObject(pTHX_ HV *stash, IDispatch *pDispatch, SV *destroy)
{
dPERINTERP;
/* returns a mortal reference to a new Perl OLE object */
IV unique = QueryPkgVar(aTHX_ stash, _UNIQUE_NAME, _UNIQUE_LEN);
if (unique) {
IUnknown *punk; // XXX check error?
pDispatch->QueryInterface(IID_IUnknown, (void**)&punk);
SV **svp = hv_fetch(g_hv_unique, (char*)&punk, sizeof(punk), FALSE);
DBG(("hv_fetch(%08x) returned %08x", punk, svp));
punk->Release();
if (svp)
return sv_2mortal(sv_bless(newRV(INT2PTR(SV*, SvIV(*svp))), stash));
}
if (!pDispatch) {
warn(MY_VERSION ": CreatePerlObject() No IDispatch interface");
DEBUGBREAK;
return &PL_sv_undef;
}
WINOLEOBJECT *pObj;
HV *hvinner = newHV();
SV *inner;
SV *sv;
GV **gv = (GV**)hv_fetch(stash, TIE_NAME, TIE_LEN, FALSE);
char *szTie = szWINOLETIE;
if (gv && (sv = GvSV(*gv)) != NULL && SvPOK(sv))
szTie = SvPV_nolen(sv);
New(0, pObj, 1, WINOLEOBJECT);
pObj->flags = 0;
pObj->pDispatch = pDispatch;
pObj->pTypeInfo = NULL;
pObj->pEnum = NULL;
pObj->pEventSink = NULL;
pObj->hashTable = newHV();
pObj->self = newHV();
pObj->destroy = NULL;
if (destroy) {
if (SvPOK(destroy))
pObj->destroy = newSVsv(destroy);
else if (SvROK(destroy) && SvTYPE(SvRV(destroy)) == SVt_PVCV)
pObj->destroy = newRV_inc(SvRV(destroy));
}
if (unique) {
IUnknown *punk; // XXX check error?
pDispatch->QueryInterface(IID_IUnknown, (void**)&punk);
/* use XIV as a weak reference */
SV **svp = hv_store(g_hv_unique, (char*)&punk, sizeof(punk),
newSViv(PTR2IV(pObj->self)), 0);
DBG(("hv_store(%08x) returned %08x", punk, svp));
punk->Release();
pObj->flags |= OBJFLAG_UNIQUE;
}
AddToObjectChain(aTHX_ &pObj->header, WINOLE_MAGIC);
DBG(("CreatePerlObject=|%lx| Class=%s Tie=%s pDispatch=0x%x\n", pObj,
HvNAME(stash), szTie, pDispatch));
hv_store(hvinner, PERL_OLE_ID, PERL_OLE_IDLEN, newSViv(PTR2IV(pObj)), 0);
inner = sv_bless(newRV_noinc((SV*)hvinner), gv_stashpv(szTie, TRUE));
sv_magic((SV*)pObj->self, inner, 'P', Nullch, 0);
SvREFCNT_dec(inner);
return sv_2mortal(sv_bless(newRV_noinc((SV*)pObj->self), stash));
} /* CreatePerlObject */
void
ReleasePerlObject(pTHX_ WINOLEOBJECT *pObj)
{
dSP;
HV *stash = SvSTASH(pObj->self);
DBG(("ReleasePerlObject |%lx|", pObj));
if (!pObj)
return;
/* ReleasePerlObject may be called multiple times for a single object:
* first by Uninitialize() and then by Win32::OLE::DESTROY.
* Make sure nothing is cleaned up twice!
*/
if (pObj->destroy) {
SV *self = sv_2mortal(newRV_inc((SV*)pObj->self));
/* honour OVERLOAD setting */
if (Gv_AMG(stash))
SvAMAGIC_on(self);
DBG((" Calling destroy method for object |%lx|\n", pObj));
ENTER;
SAVETMPS;
if (SvPOK(pObj->destroy)) {
/* $self->Dispatch($destroy,$retval); */
EXTEND(SP, 3);
PUSHMARK(sp);
PUSHs(self);
PUSHs(pObj->destroy);
PUSHs(sv_newmortal());
PUTBACK;
perl_call_method("Dispatch", G_DISCARD);
}
else {
/* &$destroy($self); */
PUSHMARK(sp);
XPUSHs(self);
PUTBACK;
perl_call_sv(pObj->destroy, G_DISCARD);
}
FREETMPS;
LEAVE;
DBG((" Returned from destroy method for 0x%08x\n", pObj));
SvREFCNT_dec(pObj->destroy);
pObj->destroy = NULL;
}
if (pObj->pEventSink) {
DBG((" Unadvise connection |%lx|", pObj));
pObj->pEventSink->Unadvise();
pObj->pEventSink = NULL;
}
if (pObj->pDispatch) {
if (pObj->flags & OBJFLAG_UNIQUE) {
dPERINTERP;
IUnknown *punk; // XXX check error?
pObj->pDispatch->QueryInterface(IID_IUnknown, (void**)&punk);
hv_delete(g_hv_unique, (char*)&punk, sizeof(punk), G_DISCARD);
DBG((" hv_delete(%08x)", punk));
punk->Release();
}
DBG((" Release pDispatch"));
pObj->pDispatch->Release();
pObj->pDispatch = NULL;
}
if (pObj->pTypeInfo) {
DBG((" Release pTypeInfo"));
pObj->pTypeInfo->Release();
pObj->pTypeInfo = NULL;
}
if (pObj->pEnum) {
DBG((" Release pEnum"));
pObj->pEnum->Release();
pObj->pEnum = NULL;
}
if (pObj->destroy) {
DBG((" destroy(%d)", SvREFCNT(pObj->destroy)));
SvREFCNT_dec(pObj->destroy);
pObj->destroy = NULL;
}
if (pObj->hashTable) {
DBG((" hashTable(%d)", SvREFCNT(pObj->hashTable)));
SvREFCNT_dec(pObj->hashTable);
pObj->hashTable = NULL;
}
DBG(("\n"));
} /* ReleasePerlObject */
WINOLEOBJECT *
GetOleObject(pTHX_ SV *sv, BOOL bDESTROY=FALSE)
{
if (sv_isobject(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV) {
SV **psv = hv_fetch((HV*)SvRV(sv), PERL_OLE_ID, PERL_OLE_IDLEN, 0);
/* Win32::OLE::Tie::DESTROY called before Win32::OLE::DESTROY? */
if (!psv && bDESTROY)
return NULL;
if (psv)
MagicGet(aTHX_ *psv);
if (psv && SvIOK(*psv)) {
WINOLEOBJECT *pObj = INT2PTR(WINOLEOBJECT*, SvIV(*psv));
DBG(("GetOleObject = |%lx|\n", pObj));
if (pObj && pObj->header.lMagic == WINOLE_MAGIC)
if (pObj->pDispatch || bDESTROY)
return pObj;
}
}
warn(MY_VERSION ": GetOleObject() Not a %s object", szWINOLE);
DEBUGBREAK;
return (WINOLEOBJECT*)NULL;
}
WINOLEENUMOBJECT *
GetOleEnumObject(pTHX_ SV *sv, BOOL bDESTROY=FALSE)
{
if (sv_isobject(sv) && sv_derived_from(sv, szWINOLEENUM)) {
WINOLEENUMOBJECT *pEnumObj = INT2PTR(WINOLEENUMOBJECT*, SvIV(SvRV(sv)));
if (pEnumObj && pEnumObj->header.lMagic == WINOLEENUM_MAGIC)
if (pEnumObj->pEnum || bDESTROY)
return pEnumObj;
}
warn(MY_VERSION ": GetOleEnumObject() Not a %s object", szWINOLEENUM);
DEBUGBREAK;
return (WINOLEENUMOBJECT*)NULL;
}
WINOLEVARIANTOBJECT *
GetOleVariantObject(pTHX_ SV *sv, BOOL bWarn=TRUE)
{
if (sv_isobject(sv) && sv_derived_from(sv, szWINOLEVARIANT)) {
WINOLEVARIANTOBJECT *pVarObj = INT2PTR(WINOLEVARIANTOBJECT*, SvIV(SvRV(sv)));
if (pVarObj && pVarObj->header.lMagic == WINOLEVARIANT_MAGIC)
return pVarObj;
}
if (bWarn) {
warn(MY_VERSION ": GetOleVariantObject() Not a %s object",
szWINOLEVARIANT);
DEBUGBREAK;
}
return (WINOLEVARIANTOBJECT*)NULL;
}
SV *
CreateTypeLibObject(pTHX_ ITypeLib *pTypeLib, TLIBATTR *pTLibAttr)
{
WINOLETYPELIBOBJECT *pObj;
New(0, pObj, 1, WINOLETYPELIBOBJECT);
pObj->pTypeLib = pTypeLib;
pObj->pTLibAttr = pTLibAttr;
AddToObjectChain(aTHX_ (OBJECTHEADER*)pObj, WINOLETYPELIB_MAGIC);
return sv_bless(newRV_noinc(newSViv(PTR2IV(pObj))),
gv_stashpv(szWINOLETYPELIB, TRUE));
}
WINOLETYPELIBOBJECT *
GetOleTypeLibObject(pTHX_ SV *sv)
{
if (sv_isobject(sv) && sv_derived_from(sv, szWINOLETYPELIB)) {
WINOLETYPELIBOBJECT *pObj = INT2PTR(WINOLETYPELIBOBJECT*, SvIV(SvRV(sv)));
if (pObj && pObj->header.lMagic == WINOLETYPELIB_MAGIC)
return pObj;
}
warn(MY_VERSION ": GetOleTypeLibObject() Not a %s object", szWINOLETYPELIB);
DEBUGBREAK;
return (WINOLETYPELIBOBJECT*)NULL;
}
SV *
CreateTypeInfoObject(pTHX_ ITypeInfo *pTypeInfo, TYPEATTR *pTypeAttr)
{
WINOLETYPEINFOOBJECT *pObj;
New(0, pObj, 1, WINOLETYPEINFOOBJECT);
pObj->pTypeInfo = pTypeInfo;
pObj->pTypeAttr = pTypeAttr;
AddToObjectChain(aTHX_ (OBJECTHEADER*)pObj, WINOLETYPEINFO_MAGIC);
return sv_bless(newRV_noinc(newSViv(PTR2IV(pObj))),
gv_stashpv(szWINOLETYPEINFO, TRUE));
}
WINOLETYPEINFOOBJECT *
GetOleTypeInfoObject(pTHX_ SV *sv)
{
if (sv_isobject(sv) && sv_derived_from(sv, szWINOLETYPEINFO)) {
WINOLETYPEINFOOBJECT *pObj = INT2PTR(WINOLETYPEINFOOBJECT*, SvIV(SvRV(sv)));
if (pObj && pObj->header.lMagic == WINOLETYPEINFO_MAGIC)
return pObj;
}
warn(MY_VERSION ": GetOleTypeInfoObject() Not a %s object",
szWINOLETYPEINFO);
DEBUGBREAK;
return (WINOLETYPEINFOOBJECT*)NULL;
}
BSTR
AllocOleString(pTHX_ char* pStr, int length, UINT cp)
{
int count = MultiByteToWideChar(cp, 0, pStr, length, NULL, 0);
BSTR bstr = SysAllocStringLen(NULL, count);
MultiByteToWideChar(cp, 0, pStr, length, bstr, count);
return bstr;
}
BSTR
AllocOleStringFromSV(pTHX_ SV *sv, UINT cp)
{
STRLEN len;
if (SvROK(sv) && sv_derived_from(sv, szUNICODESTRING)) {
sv = SvRV(sv);
U16 *pus = (U16*)SvPV(sv, len);
BSTR bstr = SysAllocStringLen(NULL, (UINT)(len/2));
for (STRLEN i=0; i < len; ++i)
bstr[i] = ntohs(pus[i]);
return bstr;
}
if (cp == CP_UTF8 && !SvUTF8(sv))
cp = CP_ACP;
char *str = SvPV(sv, len);
int count = MultiByteToWideChar(cp, 0, str, (int)len, NULL, 0);
BSTR bstr = SysAllocStringLen(NULL, count);
MultiByteToWideChar(cp, 0, str, (int)len, bstr, count);
return bstr;
}
HRESULT
GetHashedDispID(pTHX_ WINOLEOBJECT *pObj, SV *sv,
DISPID &dispID, LCID lcid, UINT cp)
{
HRESULT hr;
if (!SvPOK(sv) || !SvLEN(sv)) {
dispID = DISPID_VALUE;
return S_OK;
}
HE *he = hv_fetch_ent(pObj->hashTable, sv, TRUE, 0);
if (SvIOK(HeVAL(he))) {
dispID = (DISPID)SvIV(HeVAL(he));
return S_OK;
}
/* not there so get info and add it */
DISPID id;
OLECHAR Buffer[OLE_BUF_SIZ];
OLECHAR *pBuffer;
pBuffer = GetWideChar(aTHX_ sv, Buffer, OLE_BUF_SIZ, cp);
hr = pObj->pDispatch->GetIDsOfNames(IID_NULL, &pBuffer, 1, lcid, &id);
ReleaseBuffer(aTHX_ pBuffer, Buffer);
/* Don't call CheckOleError! Caller might retry the "unnamed" method */
if (SUCCEEDED(hr)) {
sv_setiv(HeVAL(he), id);
dispID = id;
}
return hr;
} /* GetHashedDispID */
void
FetchTypeInfo(pTHX_ WINOLEOBJECT *pObj)
{
unsigned int count;
ITypeInfo *pTypeInfo;
TYPEATTR *pTypeAttr;
HV *stash = SvSTASH(pObj->self);
if (pObj->pTypeInfo)
return;
HRESULT hr = pObj->pDispatch->GetTypeInfoCount(&count);
if (hr == E_NOTIMPL || count == 0) {
DBG(("GetTypeInfoCount returned %u (count=%d)", hr, count));
return;
}
if (CheckOleError(aTHX_ stash, hr)) {
warn(MY_VERSION ": FetchTypeInfo() GetTypeInfoCount failed");
DEBUGBREAK;
return;
}
LCID lcid = (LCID)QueryPkgVar(aTHX_ stash, LCID_NAME, LCID_LEN, lcidDefault);
hr = pObj->pDispatch->GetTypeInfo(0, lcid, &pTypeInfo);
if (CheckOleError(aTHX_ stash, hr))
return;
hr = pTypeInfo->GetTypeAttr(&pTypeAttr);
if (FAILED(hr)) {
pTypeInfo->Release();
ReportOleError(aTHX_ stash, hr);
return;
}
if (pTypeAttr->typekind != TKIND_DISPATCH) {
int cImplTypes = pTypeAttr->cImplTypes;
pTypeInfo->ReleaseTypeAttr(pTypeAttr);
pTypeAttr = NULL;
for (int i=0; i < cImplTypes; ++i) {
HREFTYPE hreftype;
ITypeInfo *pRefTypeInfo;
hr = pTypeInfo->GetRefTypeOfImplType(i, &hreftype);
if (FAILED(hr))
break;
hr = pTypeInfo->GetRefTypeInfo(hreftype, &pRefTypeInfo);
if (FAILED(hr))
break;
hr = pRefTypeInfo->GetTypeAttr(&pTypeAttr);
if (FAILED(hr)) {
pRefTypeInfo->Release();
break;
}
if (pTypeAttr->typekind == TKIND_DISPATCH) {
pTypeInfo->Release();
pTypeInfo = pRefTypeInfo;
break;
}
pRefTypeInfo->ReleaseTypeAttr(pTypeAttr);
pRefTypeInfo->Release();
pTypeAttr = NULL;
}
}
if (FAILED(hr)) {
pTypeInfo->Release();
ReportOleError(aTHX_ stash, hr);
return;
}
if (pTypeAttr) {
if (pTypeAttr->typekind == TKIND_DISPATCH) {
pObj->cFuncs = pTypeAttr->cFuncs;
pObj->cVars = pTypeAttr->cVars;
pObj->PropIndex = 0;
pObj->pTypeInfo = pTypeInfo;
}
pTypeInfo->ReleaseTypeAttr(pTypeAttr);
if (!pObj->pTypeInfo)
pTypeInfo->Release();
}
} /* FetchTypeInfo */
SV *
NextPropertyName(pTHX_ WINOLEOBJECT *pObj)
{
HRESULT hr;
unsigned int cName;
BSTR bstr;
if (!pObj->pTypeInfo)
return NULL;
HV *stash = SvSTASH(pObj->self);
UINT cp = (UINT)QueryPkgVar(aTHX_ stash, CP_NAME, CP_LEN, cpDefault);
int newenum = (int)QueryPkgVar(aTHX_ stash, _NEWENUM_NAME, _NEWENUM_LEN);
while (pObj->PropIndex < (UINT)(pObj->cFuncs+pObj->cVars)) {
ULONG index = pObj->PropIndex++;
/* Try all the INVOKE_PROPERTYGET functions first */
if (index < pObj->cFuncs) {
FUNCDESC *pFuncDesc;
hr = pObj->pTypeInfo->GetFuncDesc(index, &pFuncDesc);
if (CheckOleError(aTHX_ stash, hr))
continue;
if (newenum && pFuncDesc->memid == DISPID_NEWENUM)
return newSVpv("_NewEnum", 8);
if (!(pFuncDesc->funckind & FUNC_DISPATCH) ||
!(pFuncDesc->invkind & INVOKE_PROPERTYGET) ||
(pFuncDesc->wFuncFlags & (FUNCFLAG_FRESTRICTED |
FUNCFLAG_FHIDDEN |
FUNCFLAG_FNONBROWSABLE)))
{
pObj->pTypeInfo->ReleaseFuncDesc(pFuncDesc);
continue;
}
hr = pObj->pTypeInfo->GetNames(pFuncDesc->memid, &bstr, 1, &cName);
pObj->pTypeInfo->ReleaseFuncDesc(pFuncDesc);
if (CheckOleError(aTHX_ stash, hr) || cName == 0 || !bstr)
continue;
SV *sv = sv_setbstr(aTHX_ NULL, bstr, cp);
SysFreeString(bstr);
return sv;
}
/* Now try the VAR_DISPATCH kind variables used by older OLE versions */
else {
VARDESC *pVarDesc;
index -= pObj->cFuncs;
hr = pObj->pTypeInfo->GetVarDesc(index, &pVarDesc);
if (CheckOleError(aTHX_ stash, hr))
continue;
if (!(pVarDesc->varkind & VAR_DISPATCH) ||
(pVarDesc->wVarFlags & (VARFLAG_FRESTRICTED |
VARFLAG_FHIDDEN |
VARFLAG_FNONBROWSABLE)))
{
pObj->pTypeInfo->ReleaseVarDesc(pVarDesc);
continue;
}
hr = pObj->pTypeInfo->GetNames(pVarDesc->memid, &bstr, 1, &cName);
pObj->pTypeInfo->ReleaseVarDesc(pVarDesc);
if (CheckOleError(aTHX_ stash, hr) || cName == 0 || !bstr)
continue;
SV *sv = sv_setbstr(aTHX_ NULL, bstr, cp);
SysFreeString(bstr);
return sv;
}
}
return NULL;
} /* NextPropertyName */
HV *
GetDocumentation(pTHX_ BSTR bstrName, BSTR bstrDocString,
DWORD dwHelpContext, BSTR bstrHelpFile)
{
HV *hv = newHV();
char szStr[OLE_BUF_SIZ];
char *pszStr;
// XXX use correct codepage ???
UINT cp = CP_ACP;
pszStr = GetMultiByte(aTHX_ bstrName, szStr, sizeof(szStr), cp);
hv_store(hv, "Name", 4, newSVpv(pszStr, 0), 0);
ReleaseBuffer(aTHX_ pszStr, szStr);
SysFreeString(bstrName);
pszStr = GetMultiByte(aTHX_ bstrDocString, szStr, sizeof(szStr), cp);
hv_store(hv, "DocString", 9, newSVpv(pszStr, 0), 0);
ReleaseBuffer(aTHX_ pszStr, szStr);
SysFreeString(bstrDocString);
pszStr = GetMultiByte(aTHX_ bstrHelpFile, szStr, sizeof(szStr), cp);
hv_store(hv, "HelpFile", 8, newSVpv(pszStr, 0), 0);
ReleaseBuffer(aTHX_ pszStr, szStr);
SysFreeString(bstrHelpFile);
hv_store(hv, "HelpContext", 11, newSViv(dwHelpContext), 0);
return hv;
} /* GetDocumentation */
HRESULT
TranslateTypeDesc(pTHX_ TYPEDESC *pTypeDesc, WINOLETYPEINFOOBJECT *pObj,
AV *av)
{
HRESULT hr = S_OK;
SV *sv = NULL;
if (pTypeDesc->vt == VT_USERDEFINED) {
ITypeInfo *pTypeInfo;
TYPEATTR *pTypeAttr;
hr = pObj->pTypeInfo->GetRefTypeInfo(pTypeDesc->hreftype, &pTypeInfo);
if (SUCCEEDED(hr)) {
hr = pTypeInfo->GetTypeAttr(&pTypeAttr);
if (SUCCEEDED(hr))
sv = CreateTypeInfoObject(aTHX_ pTypeInfo, pTypeAttr);
else
pTypeInfo->Release();
}
if (!sv)
sv = newSVsv(&PL_sv_undef);
}
else if (pTypeDesc->vt == VT_CARRAY) {
// XXX to be done
sv = newSViv(pTypeDesc->vt);
}
else
sv = newSViv(pTypeDesc->vt);
av_push(av, sv);
if (pTypeDesc->vt == VT_PTR || pTypeDesc->vt == VT_SAFEARRAY)
hr = TranslateTypeDesc(aTHX_ pTypeDesc->lptdesc, pObj, av);
return hr;
}
HV *
TranslateElemDesc(pTHX_ ELEMDESC *pElemDesc, WINOLETYPEINFOOBJECT *pObj,
HV *olestash)
{
HV *hv = newHV();
AV *av = newAV();
TranslateTypeDesc(aTHX_ &pElemDesc->tdesc, pObj, av);
hv_store(hv, "vt", 2, newRV_noinc((SV*)av), 0);
USHORT wParamFlags = pElemDesc->paramdesc.wParamFlags;
hv_store(hv, "wParamFlags", 11, newSViv(wParamFlags), 0);
USHORT wMask = PARAMFLAG_FOPT|PARAMFLAG_FHASDEFAULT;
if ((wParamFlags & wMask) == wMask) {
PARAMDESCEX *pParamDescEx = pElemDesc->paramdesc.pparamdescex;
hv_store(hv, "cBytes", 6, newSViv(pParamDescEx->cBytes), 0);
// XXX should be stored as a Win32::OLE::Variant object ?
SV *sv = newSV(0);
// XXX check return code
SetSVFromVariantEx(aTHX_ &pParamDescEx->varDefaultValue,
sv, olestash);
hv_store(hv, "varDefaultValue", 15, sv, 0);
}
return hv;
} /* TranslateElemDesc */
HRESULT
FindIID(pTHX_ WINOLEOBJECT *pObj, char *pszItf, IID *piid,
ITypeInfo **ppTypeInfo, UINT cp, LCID lcid)
{
ITypeInfo *pTypeInfo;
ITypeLib *pTypeLib;
if (ppTypeInfo)
*ppTypeInfo = NULL;
// Determine containing type library
HRESULT hr = pObj->pDispatch->GetTypeInfo(0, lcid, &pTypeInfo);
DBG((" GetTypeInfo: 0x%08x\n", hr));
if (FAILED(hr))
return hr;
unsigned int index;
hr = pTypeInfo->GetContainingTypeLib(&pTypeLib, &index);
pTypeInfo->Release();
DBG((" GetContainingTypeLib: 0x%08x\n", hr));
if (FAILED(hr))
return hr;
// piid maybe already set by IProvideClassInfo2::GetGUID
if (!pszItf) {
hr = pTypeLib->GetTypeInfoOfGuid(*piid, ppTypeInfo);
DBG((" GetTypeInfoOfGuid: 0x%08x\n", hr));
pTypeLib->Release();
return hr;
}
// Walk through all type definitions in the library
BOOL bFound = FALSE;
unsigned int count = pTypeLib->GetTypeInfoCount();
for (index = 0; index < count; ++index) {
TYPEATTR *pTypeAttr;
hr = pTypeLib->GetTypeInfo(index, &pTypeInfo);
if (FAILED(hr))
break;
hr = pTypeInfo->GetTypeAttr(&pTypeAttr);
if (FAILED(hr)) {
pTypeInfo->Release();
break;
}
// DBG((" TypeInfo %d typekind %d\n", index, pTypeAttr->typekind));
// Look into all COCLASSes
if (pTypeAttr->typekind == TKIND_COCLASS) {
// Walk through all implemented types
for (unsigned int type=0; type < pTypeAttr->cImplTypes; ++type) {
HREFTYPE RefType;
ITypeInfo *pImplTypeInfo;
hr = pTypeInfo->GetRefTypeOfImplType(type, &RefType);
if (FAILED(hr))
break;
hr = pTypeInfo->GetRefTypeInfo(RefType, &pImplTypeInfo);
if (FAILED(hr))
break;
BSTR bstr;
hr = pImplTypeInfo->GetDocumentation(-1, &bstr, NULL,
NULL, NULL);
if (FAILED(hr)) {
pImplTypeInfo->Release();
break;
}
char szStr[OLE_BUF_SIZ];
char *pszStr = GetMultiByte(aTHX_ bstr, szStr,
sizeof(szStr), cp);
if (strEQ(pszItf, pszStr)) {
TYPEATTR *pImplTypeAttr;
hr = pImplTypeInfo->GetTypeAttr(&pImplTypeAttr);
if (SUCCEEDED(hr)) {
bFound = TRUE;
*piid = pImplTypeAttr->guid;
if (ppTypeInfo) {
*ppTypeInfo = pImplTypeInfo;
(*ppTypeInfo)->AddRef();
}
pImplTypeInfo->ReleaseTypeAttr(pImplTypeAttr);
}
}
ReleaseBuffer(aTHX_ pszStr, szStr);
pImplTypeInfo->Release();
if (bFound || FAILED(hr))
break;
}
}
pTypeInfo->ReleaseTypeAttr(pTypeAttr);
pTypeInfo->Release();
if (bFound || FAILED(hr))
break;
}
pTypeLib->Release();
DBG((" after loop: 0x%08x\n", hr));
if (FAILED(hr))
return hr;
if (!bFound) {
warn(MY_VERSION "FindIID: Interface '%s' not found", pszItf);
return E_NOINTERFACE;
}
#ifdef _DEBUG
OLECHAR wszGUID[80];
int len = StringFromGUID2(*piid, wszGUID, sizeof(wszGUID)/sizeof(OLECHAR));
char szStr[OLE_BUF_SIZ];
char *pszStr = GetMultiByte(aTHX_ wszGUID, szStr, sizeof(szStr), cp);
DBG(("FindIID: %s is %s", pszItf, pszStr));
ReleaseBuffer(aTHX_ pszStr, szStr);
#endif
return S_OK;
} /* FindIID */
HRESULT
FindDefaultSource(pTHX_ WINOLEOBJECT *pObj, IID *piid,
ITypeInfo **ppTypeInfo, UINT cp, LCID lcid)
{
HRESULT hr;
*ppTypeInfo = NULL;
// Try IProvideClassInfo2 interface first
IProvideClassInfo2 *pProvideClassInfo2;
hr = pObj->pDispatch->QueryInterface(IID_IProvideClassInfo2,
(void**)&pProvideClassInfo2);
DBG(("QueryInterface(IProvideClassInfo2): hr=0x%08x\n", hr));
if (SUCCEEDED(hr)) {
hr = pProvideClassInfo2->GetGUID(GUIDKIND_DEFAULT_SOURCE_DISP_IID,
piid);
pProvideClassInfo2->Release();
DBG(("GetGUID: hr=0x%08x\n", hr));
return FindIID(aTHX_ pObj, NULL, piid, ppTypeInfo, cp, lcid);
}
IProvideClassInfo *pProvideClassInfo;
hr = pObj->pDispatch->QueryInterface(IID_IProvideClassInfo,
(void**)&pProvideClassInfo);
DBG(("QueryInterface(IProvideClassInfo): hr=0x%08x\n", hr));
if (FAILED(hr))
return hr;
// Get ITypeInfo* for COCLASS of this object
ITypeInfo *pTypeInfo;
hr = pProvideClassInfo->GetClassInfo(&pTypeInfo);
pProvideClassInfo->Release();
DBG(("GetClassInfo: hr=0x%08x\n", hr));
if (FAILED(hr))
return hr;
// Get Type Attributes
TYPEATTR *pTypeAttr;
hr = pTypeInfo->GetTypeAttr(&pTypeAttr);
DBG(("GetTypeAttr: hr=0x%08x\n", hr));
if (FAILED(hr)) {
pTypeInfo->Release();
return hr;
}
UINT i;
int iFlags;
// Enumerate all implemented types of the COCLASS
for (i=0; i < pTypeAttr->cImplTypes; i++) {
hr = pTypeInfo->GetImplTypeFlags(i, &iFlags);
DBG(("GetImplTypeFlags: hr=0x%08x i=%d iFlags=%d\n", hr, i, iFlags));
if (FAILED(hr))
continue;
// looking for the [default] [source]
// we just hope that it is a dispinterface :-)
if ((iFlags & IMPLTYPEFLAG_FDEFAULT) &&
(iFlags & IMPLTYPEFLAG_FSOURCE))
{
HREFTYPE hRefType = 0;
hr = pTypeInfo->GetRefTypeOfImplType(i, &hRefType);
DBG(("GetRefTypeOfImplType: hr=0x%08x\n", hr));
if (FAILED(hr))
continue;
hr = pTypeInfo->GetRefTypeInfo(hRefType, ppTypeInfo);
DBG(("GetRefTypeInfo: hr=0x%08x\n", hr));
if (SUCCEEDED(hr))
break;
}
}
pTypeInfo->ReleaseTypeAttr(pTypeAttr);
pTypeInfo->Release();
// Now that would be a bad surprise, if we didn't find it, wouldn't it?
if (!*ppTypeInfo) {
if (SUCCEEDED(hr))
hr = E_UNEXPECTED;
return hr;
}
// Determine IID of default source interface
hr = (*ppTypeInfo)->GetTypeAttr(&pTypeAttr);
if (SUCCEEDED(hr)) {
*piid = pTypeAttr->guid;
(*ppTypeInfo)->ReleaseTypeAttr(pTypeAttr);
}
else
(*ppTypeInfo)->Release();
return hr;
} /* FindDefaultSource */
IEnumVARIANT *
CreateEnumVARIANT(pTHX_ WINOLEOBJECT *pObj)
{
unsigned int argErr;
EXCEPINFO excepinfo;
DISPPARAMS dispParams;
VARIANT result;
HRESULT hr;
IEnumVARIANT *pEnum = NULL;
VariantInit(&result);
dispParams.rgvarg = NULL;
dispParams.rgdispidNamedArgs = NULL;
dispParams.cNamedArgs = 0;
dispParams.cArgs = 0;
HV *stash = SvSTASH(pObj->self);
LCID lcid = (LCID)QueryPkgVar(aTHX_ stash, LCID_NAME, LCID_LEN, lcidDefault);
Zero(&excepinfo, 1, EXCEPINFO);
hr = pObj->pDispatch->Invoke(DISPID_NEWENUM, IID_NULL,
lcid, DISPATCH_METHOD | DISPATCH_PROPERTYGET,
&dispParams, &result, &excepinfo, &argErr);
if (SUCCEEDED(hr)) {
if (V_VT(&result) == VT_UNKNOWN)
hr = V_UNKNOWN(&result)->QueryInterface(IID_IEnumVARIANT,
(void**)&pEnum);
else if (V_VT(&result) == VT_DISPATCH)
hr = V_DISPATCH(&result)->QueryInterface(IID_IEnumVARIANT,
(void**)&pEnum);
}
VariantClear(&result);
CheckOleError(aTHX_ stash, hr, &excepinfo);
return pEnum;
} /* CreateEnumVARIANT */
SV *
NextEnumElement(pTHX_ IEnumVARIANT *pEnum, HV *stash)
{
SV *sv = NULL;
VARIANT variant;
VariantInit(&variant);
if (pEnum->Next(1, &variant, NULL) == S_OK) {
sv = newSV(0);
HRESULT hr = SetSVFromVariantEx(aTHX_ &variant, sv, stash);
if (FAILED(hr)) {
SvREFCNT_dec(sv);
sv = NULL;
ReportOleError(aTHX_ stash, hr);
}
VariantClear(&variant);
}
return sv;
} /* NextEnumElement */
//------------------------------------------------------------------------
EventSink::EventSink(pTHX_ WINOLEOBJECT *pObj, SV *events,
REFIID riid, ITypeInfo *pTypeInfo)
{
DBG(("EventSink::EventSink\n"));
m_pObj = pObj;
m_events = newSVsv(events);
m_iid = riid;
m_pTypeInfo = pTypeInfo;
m_refcount = 1;
#ifdef PERL_IMPLICIT_CONTEXT
this->aTHX = aTHX;
#endif
}
EventSink::~EventSink(void)
{
#ifdef PERL_IMPLICIT_CONTEXT
pTHX = PERL_GET_THX;
PERL_SET_THX(this->aTHX);
#endif
DBG(("EventSink::~EventSink\n"));
if (m_pTypeInfo)
m_pTypeInfo->Release();
SvREFCNT_dec(m_events);
#ifdef PERL_IMPLICIT_CONTEXT
PERL_SET_THX(aTHX);
#endif
}
HRESULT
EventSink::Advise(IConnectionPoint *pConnectionPoint)
{
HRESULT hr = pConnectionPoint->Advise((IUnknown*)this, &m_dwCookie);
if (SUCCEEDED(hr)) {
m_pConnectionPoint = pConnectionPoint;
m_pConnectionPoint->AddRef();
}
return hr;
}
void
EventSink::Unadvise(void)
{
if (m_pConnectionPoint) {
m_pConnectionPoint->Unadvise(m_dwCookie);
m_pConnectionPoint->Release();
}
m_pConnectionPoint = NULL;
Release();
}
STDMETHODIMP
EventSink::QueryInterface(REFIID iid, void **ppv)
{
#ifdef _DEBUG
# ifdef PERL_IMPLICIT_CONTEXT
pTHX = PERL_GET_THX;
PERL_SET_THX(this->aTHX);
# endif
OLECHAR wszGUID[80];
int len = StringFromGUID2(iid, wszGUID, sizeof(wszGUID)/sizeof(OLECHAR));
char szStr[OLE_BUF_SIZ];
char *pszStr = GetMultiByte(aTHX_ wszGUID, szStr, sizeof(szStr), CP_ACP);
DBG(("***QueryInterface %s\n", pszStr));
ReleaseBuffer(aTHX_ pszStr, szStr);
# ifdef PERL_IMPLICIT_CONTEXT
PERL_SET_THX(aTHX);
# endif
#endif
if (iid == IID_IUnknown || iid == IID_IDispatch || iid == m_iid)
*ppv = this;
else {
DBG((" failed\n"));
*ppv = NULL;
return E_NOINTERFACE;
}
DBG((" succeeded\n"));
AddRef();
return S_OK;
}
STDMETHODIMP_(ULONG)
EventSink::AddRef(void)
{
++m_refcount;
DBG(("***AddRef refcount=%d\n", m_refcount));
return m_refcount;
}
STDMETHODIMP_(ULONG)
EventSink::Release(void)
{
--m_refcount;
DBG(("***Release refcount=%d\n", m_refcount));
if (m_refcount)
return m_refcount;
delete this;
return 0;
}
STDMETHODIMP
EventSink::GetTypeInfoCount(UINT *pctinfo)
{
DBG(("***GetTypeInfoCount\n"));
*pctinfo = 0;
return S_OK;
}
STDMETHODIMP
EventSink::GetTypeInfo(UINT itinfo, LCID lcid, ITypeInfo **pptinfo)
{
DBG(("***GetTypeInfo\n"));
*pptinfo = NULL;
return DISP_E_BADINDEX;
}
STDMETHODIMP
EventSink::GetIDsOfNames(
REFIID riid,
OLECHAR **rgszNames,
UINT cNames,
LCID lcid,
DISPID *rgdispid)
{
DBG(("***GetIDsOfNames\n"));
// XXX Set all DISPIDs to DISPID_UNKNOWN
return DISP_E_UNKNOWNNAME;
}
STDMETHODIMP
EventSink::Invoke(
DISPID dispidMember,
REFIID riid,
LCID lcid,
WORD wFlags,
DISPPARAMS *pdispparams,
VARIANT *pvarResult,
EXCEPINFO *pexcepinfo,
UINT *puArgErr)
{
#ifdef PERL_IMPLICIT_CONTEXT
pTHX = PERL_GET_THX;
PERL_SET_THX(this->aTHX);
#endif
DBG(("***Invoke dispid=%d args=%d\n", dispidMember, pdispparams->cArgs));
BSTR bstr;
unsigned int count;
HRESULT hr;
SV *event = Nullsv;
if (m_pTypeInfo) {
hr = m_pTypeInfo->GetNames(dispidMember, &bstr, 1, &count);
if (FAILED(hr)) {
DBG((" GetNames failed: 0x%08x\n", hr));
#ifdef PERL_IMPLICIT_CONTEXT
PERL_SET_THX(aTHX);
#endif
return S_OK;
}
event = sv_2mortal(sv_setbstr(aTHX_ NULL, bstr, CP_ACP));
SysFreeString(bstr);
}
else {
DBG((" No type library available\n"));
STRLEN n_a;
event = sv_2mortal(newSViv(dispidMember));
SvPV_force(event, n_a);
}
DBG((" Event %s\n", SvPVX(event)));
SV *callback = NULL;
BOOL pushname = FALSE;
if (SvROK(m_events) && SvTYPE(SvRV(m_events)) == SVt_PVCV) {
callback = m_events;
pushname = TRUE;
}
else if (SvPOK(m_events)) {
HV *stash = gv_stashsv(m_events, FALSE);
if (stash) {
GV **pgv = (GV**)hv_fetch(stash, SvPVX(event), (I32)SvCUR(event), FALSE);
if (pgv && GvCV(*pgv))
callback = (SV*)GvCV(*pgv);
}
}
if (callback) {
dSP;
SV *self = newRV_inc((SV*)m_pObj->self);
if (Gv_AMG(SvSTASH(m_pObj->self)))
SvAMAGIC_on(self);
ENTER;
SAVETMPS;
PUSHMARK(sp);
XPUSHs(sv_2mortal(self));
if (pushname)
XPUSHs(event);
for (unsigned int i=0; i < pdispparams->cArgs; ++i) {
VARIANT *pVariant = &pdispparams->rgvarg[pdispparams->cArgs-i-1];
DBG((" Arg %d vt=0x%04x\n", i, V_VT(pVariant)));
SV *sv = sv_newmortal();
// XXX Check return code
SetSVFromVariantEx(aTHX_ pVariant, sv, SvSTASH(m_pObj->self), TRUE);
XPUSHs(sv);
}
PUTBACK;
perl_call_sv(callback, G_DISCARD);
SPAGAIN;
FREETMPS;
LEAVE;
}
#ifdef PERL_IMPLICIT_CONTEXT
PERL_SET_THX(aTHX);
#endif
return S_OK;
}
//------------------------------------------------------------------------
Forwarder::Forwarder(pTHX_ HV *stash, SV *method)
{
m_stash = stash; // XXX refcount?
m_method = newSVsv(method);
m_refcount = 1;
#ifdef PERL_IMPLICIT_CONTEXT
this->aTHX = aTHX;
#endif
}
Forwarder::~Forwarder(void)
{
#ifdef PERL_IMPLICIT_CONTEXT
pTHX = PERL_GET_THX;
PERL_SET_THX(this->aTHX);
#endif
SvREFCNT_dec(m_method);
#ifdef PERL_IMPLICIT_CONTEXT
PERL_SET_THX(aTHX);
#endif
}
STDMETHODIMP
Forwarder::QueryInterface(REFIID iid, void **ppv)
{
if (iid == IID_IUnknown || iid == IID_IDispatch) {
*ppv = this;
AddRef();
return S_OK;
}
*ppv = NULL;
return E_NOINTERFACE;
}
STDMETHODIMP_(ULONG)
Forwarder::AddRef(void)
{
return ++m_refcount;
}
STDMETHODIMP_(ULONG)
Forwarder::Release(void)
{
if (--m_refcount)
return m_refcount;
delete this;
return 0;
}
STDMETHODIMP
Forwarder::GetTypeInfoCount(UINT *pctinfo)
{
*pctinfo = 0;
return S_OK;
}
STDMETHODIMP
Forwarder::GetTypeInfo(UINT itinfo, LCID lcid, ITypeInfo **pptinfo)
{
*pptinfo = NULL;
return DISP_E_BADINDEX;
}
STDMETHODIMP
Forwarder::GetIDsOfNames(
REFIID riid,
OLECHAR **rgszNames,
UINT cNames,
LCID lcid,
DISPID *rgdispid)
{
DBG(("Forwarder::GetIDsOfNames cNames=%d\n", cNames));
// XXX Set all DISPIDs to DISPID_UNKNOWN
return DISP_E_UNKNOWNNAME;
}
STDMETHODIMP
Forwarder::Invoke(
DISPID dispidMember,
REFIID riid,
LCID lcid,
WORD wFlags,
DISPPARAMS *pdispparams,
VARIANT *pvarResult,
EXCEPINFO *pexcepinfo,
UINT *puArgErr)
{
#ifdef PERL_IMPLICIT_CONTEXT
pTHX = PERL_GET_THX;
PERL_SET_THX(this->aTHX);
#endif
DBG(("Forwarder::Invoke dispid=%d args=%d\n",
dispidMember, pdispparams->cArgs));
dSP;
ENTER;
SAVETMPS;
PUSHMARK(sp);
for (unsigned int i=0; i < pdispparams->cArgs; ++i) {
VARIANT *pVariant = &pdispparams->rgvarg[pdispparams->cArgs-i-1];
DBG((" Arg %d vt=0x%04x\n", i, V_VT(pVariant)));
SV *sv = sv_newmortal();
// XXX Check return code
SetSVFromVariantEx(aTHX_ pVariant, sv, m_stash, TRUE);
XPUSHs(sv);
}
PUTBACK;
perl_call_sv(m_method, G_DISCARD);
SPAGAIN;
FREETMPS;
LEAVE;
#ifdef PERL_IMPLICIT_CONTEXT
PERL_SET_THX(aTHX);
#endif
return S_OK;
}
//------------------------------------------------------------------------
HRESULT
MyVariantCopy(VARIANTARG *dest, VARIANTARG *src)
{
// VariantCopy() doesn't preserve vbNullString semantics
if (V_VT(src) == VT_BSTR && V_BSTR(src) == NULL) {
VariantClear(dest);
V_VT(dest) = VT_BSTR;
V_BSTR(dest) = NULL;
return S_OK;
}
return VariantCopy(dest, src);
}
void
ClearVariantObject(WINOLEVARIANTOBJECT *pVarObj)
{
if (!pVarObj)
return;
VARIANT *pVariant = &pVarObj->variant;
VARTYPE vt = V_VT(pVariant);
if (vt & VT_BYREF) {
switch (vt & ~VT_BYREF) {
case VT_BSTR:
SysFreeString(*V_BSTRREF(pVariant));
break;
case VT_DISPATCH:
if (*V_DISPATCHREF(pVariant))
(*V_DISPATCHREF(pVariant))->Release();
break;
case VT_UNKNOWN:
if (*V_UNKNOWNREF(pVariant))
(*V_UNKNOWNREF(pVariant))->Release();
break;
}
VariantInit(pVariant);
}
else
VariantClear(pVariant);
}
SV *
SetSVFromGUID(pTHX_ REFGUID rguid)
{
dSP;
SV *sv = newSVsv(&PL_sv_undef);
CV *cv = perl_get_cv("Win32::COM::GUID::new", FALSE);
if (cv) {
EXTEND(SP, 2);
PUSHMARK(sp);
PUSHs(sv_2mortal(newSVpv("Win32::COM::GUID", 0)));
PUSHs(sv_2mortal(newSVpv((char*)&rguid, sizeof(GUID))));
PUTBACK;
int count = perl_call_sv((SV*)cv, G_SCALAR);
SPAGAIN;
if (count == 1)
sv_setsv(sv, POPs);
PUTBACK;
}
else {
OLECHAR wszGUID[80];
int len = StringFromGUID2(rguid, wszGUID,
sizeof(wszGUID)/sizeof(OLECHAR));
if (len > 3) {
BSTR bstr = SysAllocStringLen(wszGUID+1, len-3);
sv_setbstr(aTHX_ sv, bstr, CP_ACP);
SysFreeString(bstr);
}
}
return sv;
}
HRESULT
SetSafeArrayFromAV(pTHX_ AV* av, VARTYPE vt, SAFEARRAY *psa,
int cDims, UINT cp, LCID lcid)
{
HRESULT hr = SafeArrayLock(psa);
if (FAILED(hr))
return hr;
if (cDims == 0)
cDims = SafeArrayGetDim(psa);
AV **pav;
LONG *pix;
long *plen;
New(0, pav, cDims, AV*);
New(0, pix, cDims, LONG);
New(0, plen, cDims, long);
pav[0] = av;
plen[0] = av_len(pav[0])+1;
Zero(pix, cDims, LONG);
VARIANT variant;
VARIANT *pElement = &variant;
if (vt != VT_VARIANT)
V_VT(pElement) = vt | VT_BYREF;
for (int index = 0; index >= 0; ) {
SV **psv = av_fetch(pav[index], pix[index], FALSE);
if (psv) {
if (SvROK(*psv) && SvTYPE(SvRV(*psv)) == SVt_PVAV) {
if (++index >= cDims) {
warn(MY_VERSION ": SetSafeArrayFromAV unexpected failure");
hr = E_UNEXPECTED;
break;
}
pav[index] = (AV*)SvRV(*psv);
pix[index] = 0;
plen[index] = av_len(pav[index])+1;
continue;
}
if (SvOK(*psv)) {
if (index+1 != cDims) {
warn(MY_VERSION ": SetSafeArrayFromAV wrong dimension");
hr = DISP_E_BADINDEX;
break;
}
if (vt == VT_VARIANT) {
hr = SafeArrayPtrOfIndex(psa, pix, (void**)&pElement);
if (SUCCEEDED(hr))
hr = SetVariantFromSVEx(aTHX_ *psv, pElement, cp, lcid);
}
else {
hr = SafeArrayPtrOfIndex(psa, pix, &V_BYREF(pElement));
if (SUCCEEDED(hr))
hr = AssignVariantFromSV(aTHX_ *psv, pElement,
cp, lcid);
}
if (hr == DISP_E_BADINDEX)
warn(MY_VERSION ": SetSafeArrayFromAV bad index");
if (FAILED(hr))
break;
}
}
while (index >= 0) {
if (++pix[index] < plen[index])
break;
pix[index--] = 0;
}
}
SafeArrayUnlock(psa);
Safefree(pav);
Safefree(pix);
Safefree(plen);
return hr;
}
HRESULT
SetVariantFromSVEx(pTHX_ SV* sv, VARIANT *pVariant, UINT cp, LCID lcid)
{
HRESULT hr = S_OK;
VariantClear(pVariant);
/* XXX requirement to call mg_get() may change in Perl > 5.005 */
MagicGet(aTHX_ sv);
/* Objects */
if (SvROK(sv)) {
if (sv_derived_from(sv, szWINOLE)) {
WINOLEOBJECT *pObj = GetOleObject(aTHX_ sv);
if (pObj) {
pObj->pDispatch->AddRef();
V_VT(pVariant) = VT_DISPATCH;
V_DISPATCH(pVariant) = pObj->pDispatch;
return S_OK;
}
return E_POINTER;
}
if (sv_derived_from(sv, szWINOLEVARIANT)) {
WINOLEVARIANTOBJECT *pVarObj =
GetOleVariantObject(aTHX_ sv);
if (pVarObj) {
/* XXX Should we use VariantCopyInd? */
hr = MyVariantCopy(pVariant, &pVarObj->variant);
}
else
hr = E_POINTER;
return hr;
}
if (sv_derived_from(sv, szUNICODESTRING)) {
V_VT(pVariant) = VT_BSTR;
V_BSTR(pVariant) = AllocOleStringFromSV(aTHX_ sv, cp);
return S_OK;
}
sv = SvRV(sv);
}
/* Arrays */
if (SvTYPE(sv) == SVt_PVAV) {
IV index;
IV dim = 1;
IV maxdim = 2;
AV **pav;
ULONG *pix;
unsigned long *plen;
SAFEARRAYBOUND *psab;
New(0, pav, maxdim, AV*);
New(0, pix, maxdim, ULONG);
New(0, plen, maxdim, unsigned long);
New(0, psab, maxdim, SAFEARRAYBOUND);
pav[0] = (AV*)sv;
pix[0] = 0;
plen[0] = av_len(pav[0])+1;
psab[0].cElements = plen[0];
psab[0].lLbound = 0;
/* Depth first walk through to determine number of dimensions */
for (index = 0; index >= 0; ) {
SV **psv = av_fetch(pav[index], pix[index], FALSE);
if (psv && SvROK(*psv) && SvTYPE(SvRV(*psv)) == SVt_PVAV) {
if (++index >= maxdim) {
maxdim *= 2;
Renew(pav, maxdim, AV*);
Renew(pix, maxdim, ULONG);
Renew(plen, maxdim, unsigned long);
Renew(psab, maxdim, SAFEARRAYBOUND);
}
pav[index] = (AV*)SvRV(*psv);
pix[index] = 0;
plen[index] = av_len(pav[index])+1;
if (index < dim) {
if (plen[index] > psab[index].cElements)
psab[index].cElements = plen[index];
}
else {
dim = index+1;
psab[index].cElements = plen[index];
psab[index].lLbound = 0;
}
continue;
}
while (index >= 0) {
if (++pix[index] < plen[index])
break;
--index;
}
}
/* Create and fill VARIANT array */
SAFEARRAY *psa = SafeArrayCreate(VT_VARIANT, (UINT)dim, psab);
if (psa)
hr = SetSafeArrayFromAV(aTHX_ (AV*)sv, VT_VARIANT, psa, (int)dim,
cp, lcid);
else
hr = E_OUTOFMEMORY;
Safefree(pav);
Safefree(pix);
Safefree(plen);
Safefree(psab);
if (SUCCEEDED(hr)) {
V_VT(pVariant) = VT_VARIANT | VT_ARRAY;
V_ARRAY(pVariant) = psa;
}
else if (psa)
SafeArrayDestroy(psa);
return hr;
}
/* Scalars */
if (SvIOK(sv)) {
V_VT(pVariant) = VT_I4;
V_I4(pVariant) = (LONG)SvIV(sv);
}
else if (SvNOK(sv)) {
V_VT(pVariant) = VT_R8;
V_R8(pVariant) = SvNV(sv);
}
else if (SvPOK(sv)) {
V_VT(pVariant) = VT_BSTR;
V_BSTR(pVariant) = AllocOleStringFromSV(aTHX_ sv, cp);
}
return hr;
} /* SetVariantFromSVEx */
HRESULT
SetVariantFromSV(pTHX_ SV* sv, VARIANT *pVariant, UINT cp)
{
/* old API for PerlScript compatibility */
return SetVariantFromSVEx(aTHX_ sv, pVariant, cp, lcidDefault);
} /* SetVariantFromSV */
HRESULT
AssignVariantFromSV(pTHX_ SV* sv, VARIANT *pVariant, UINT cp, LCID lcid)
{
/* This function is similar to SetVariantFromSVEx except that
* it does NOT choose the variant type itself.
*/
HRESULT hr = S_OK;
VARTYPE vt = V_VT(pVariant);
/* sv must NOT be Nullsv unless vt is VT_EMPTY, VT_NULL, VT_BSTR,
* VT_DISPATCH or VT_VARIANT
*/
# define ASSIGN(vartype,perltype,ctype) \
if (vt & VT_BYREF) { \
*V_##vartype##REF(pVariant) = (ctype)Sv##perltype (sv); \
} else { \
V_##vartype(pVariant) = (ctype)Sv##perltype (sv); \
}
/* XXX requirement to call mg_get() may change in Perl > 5.005 */
if (sv)
MagicGet(aTHX_ sv);
if (vt & VT_ARRAY) {
SAFEARRAY *psa;
if (V_ISBYREF(pVariant))
psa = *V_ARRAYREF(pVariant);
else
psa = V_ARRAY(pVariant);
UINT cDims = SafeArrayGetDim(psa);
if ((vt & VT_TYPEMASK) != VT_UI1 || cDims != 1 || !sv || !SvPOK(sv)) {
warn(MY_VERSION ": AssignVariantFromSV() cannot assign to "
"VT_ARRAY variant");
return E_INVALIDARG;
}
char *pDest;
STRLEN len;
char *pSrc = SvPV(sv, len);
HRESULT hr = SafeArrayAccessData(psa, (void**)&pDest);
if (SUCCEEDED(hr)) {
LONG lLower, lUpper;
SafeArrayGetLBound(psa, 1, &lLower);
SafeArrayGetUBound(psa, 1, &lUpper);
unsigned long lLength = 1 + lUpper-lLower;
len = (len < lLength ? len : lLength);
memcpy(pDest, pSrc, len);
if (lLength > len)
memset(pDest+len, 0, lLength-len);
SafeArrayUnaccessData(psa);
}
return hr;
}
VARTYPE vt_base = vt & VT_TYPEMASK;
switch (vt_base) {
case VT_EMPTY:
case VT_NULL:
break;
case VT_I2:
ASSIGN(I2, IV, short);
break;
case VT_I4:
ASSIGN(I4, IV, int);
break;
case VT_R4:
ASSIGN(R4, NV, float);
break;
case VT_R8:
ASSIGN(R8, NV, double);
break;
case VT_CY:
case VT_DATE:
{
VARIANT variant;
if (SvIOK(sv)) {
V_VT(&variant) = VT_I4;
V_I4(&variant) = (LONG)SvIV(sv);
}
else if (SvNOK(sv)) {
V_VT(&variant) = VT_R8;
V_R8(&variant) = SvNV(sv);
}
else {
V_VT(&variant) = VT_BSTR;
V_BSTR(&variant) = AllocOleStringFromSV(aTHX_ sv, cp);
}
hr = VariantChangeTypeEx(&variant, &variant, lcid, 0, vt_base);
if (SUCCEEDED(hr)) {
if (vt_base == VT_CY) {
if (vt & VT_BYREF)
*V_CYREF(pVariant) = V_CY(&variant);
else
V_CY(pVariant) = V_CY(&variant);
}
else {
if (vt & VT_BYREF)
*V_DATEREF(pVariant) = V_DATE(&variant);
else
V_DATE(pVariant) = V_DATE(&variant);
}
}
VariantClear(&variant);
break;
}
case VT_BSTR:
{
BSTR bstr = sv ? AllocOleStringFromSV(aTHX_ sv, cp) : NULL;
if (vt & VT_BYREF) {
SysFreeString(*V_BSTRREF(pVariant));
*V_BSTRREF(pVariant) = bstr;
}
else {
SysFreeString(V_BSTR(pVariant));
V_BSTR(pVariant) = bstr;
}
break;
}
case VT_DISPATCH:
if (vt & VT_BYREF) {
if (*V_DISPATCHREF(pVariant))
(*V_DISPATCHREF(pVariant))->Release();
*V_DISPATCHREF(pVariant) = NULL;
}
else {
if (V_DISPATCH(pVariant))
V_DISPATCH(pVariant)->Release();
V_DISPATCH(pVariant) = NULL;
}
if (sv_isobject(sv)) {
/* Argument MUST be a valid Perl OLE object! */
WINOLEOBJECT *pObj = GetOleObject(aTHX_ sv);
if (pObj) {
pObj->pDispatch->AddRef();
if (vt & VT_BYREF)
*V_DISPATCHREF(pVariant) = pObj->pDispatch;
else
V_DISPATCH(pVariant) = pObj->pDispatch;
}
}
break;
case VT_ERROR:
ASSIGN(ERROR, IV, unsigned short);
break;
case VT_BOOL:
if (vt & VT_BYREF)
*V_BOOLREF(pVariant) = SvTRUE(sv) ? VARIANT_TRUE : VARIANT_FALSE;
else
V_BOOL(pVariant) = SvTRUE(sv) ? VARIANT_TRUE : VARIANT_FALSE;
break;
case VT_VARIANT:
if (vt & VT_BYREF)
if (sv)
hr = SetVariantFromSVEx(aTHX_ sv, V_VARIANTREF(pVariant), cp, lcid);
else
VariantClear(V_VARIANTREF(pVariant));
else {
warn(MY_VERSION ": AssignVariantFromSV() with invalid type: "
"VT_VARIANT without VT_BYREF");
hr = E_INVALIDARG;
}
break;
case VT_UNKNOWN:
{
/* Argument MUST be a valid Perl OLE object! */
/* Query IUnknown interface to allow identity tests */
WINOLEOBJECT *pObj = GetOleObject(aTHX_ sv);
if (pObj) {
IUnknown *punk;
hr = pObj->pDispatch->QueryInterface(IID_IUnknown, (void**)&punk);
if (SUCCEEDED(hr)) {
if (vt & VT_BYREF) {
if (*V_UNKNOWNREF(pVariant))
(*V_UNKNOWNREF(pVariant))->Release();
*V_UNKNOWNREF(pVariant) = punk;
}
else {
if (V_UNKNOWN(pVariant))
V_UNKNOWN(pVariant)->Release();
V_UNKNOWN(pVariant) = punk;
}
}
}
break;
}
case VT_DECIMAL:
{
VARIANT variant;
VariantInit(&variant);
V_VT(&variant) = VT_BSTR;
V_BSTR(&variant) = AllocOleStringFromSV(aTHX_ sv, cp);
hr = VariantChangeTypeEx(&variant, &variant, lcid, 0, VT_DECIMAL);
if (SUCCEEDED(hr)) {
if (vt & VT_BYREF)
*V_DECIMALREF(pVariant) = V_DECIMAL(&variant);
else
V_DECIMAL(pVariant) = V_DECIMAL(&variant);
}
VariantClear(&variant);
break;
}
case VT_UI1:
if (SvIOK(sv)) {
ASSIGN(UI1, IV, unsigned char);
}
else {
char *ptr = SvPV_nolen(sv);
if (vt & VT_BYREF)
*V_UI1REF(pVariant) = *ptr;
else
V_UI1(pVariant) = *ptr;
}
break;
default:
warn(MY_VERSION " AssignVariantFromSV() cannot assign to "
"vt=0x%x", vt);
hr = E_INVALIDARG;
}
return hr;
# undef ASSIGN
} /* AssignVariantFromSV */
HRESULT
SetSVFromVariantEx(pTHX_ VARIANTARG *pVariant, SV* sv, HV *stash,
BOOL bByRefObj)
{
HRESULT hr = S_OK;
VARTYPE vt = V_VT(pVariant);
# define SET(perltype,vartype) \
if (vt & VT_BYREF) { \
sv_set##perltype (sv, *V_##vartype##REF(pVariant)); \
} else { \
sv_set##perltype (sv, V_##vartype (pVariant)); \
}
sv_setsv(sv, &PL_sv_undef);
if (V_ISBYREF(pVariant) && bByRefObj) {
WINOLEVARIANTOBJECT *pVarObj;
Newz(0, pVarObj, 1, WINOLEVARIANTOBJECT);
VariantInit(&pVarObj->variant);
VariantInit(&pVarObj->byref);
hr = VariantCopy(&pVarObj->variant, pVariant);
if (FAILED(hr)) {
Safefree(pVarObj);
return hr;
}
AddToObjectChain(aTHX_ (OBJECTHEADER*)pVarObj, WINOLEVARIANT_MAGIC);
SV *classname = newSVpv(HvNAME(stash), 0);
sv_catpvn(classname, "::Variant", 9);
sv_setref_pv(sv, SvPVX(classname), pVarObj);
SvREFCNT_dec(classname);
return hr;
}
while (vt == (VT_VARIANT|VT_BYREF)) {
pVariant = V_VARIANTREF(pVariant);
vt = V_VT(pVariant);
}
if (V_ISARRAY(pVariant)) {
VARTYPE vt_base = vt & VT_TYPEMASK;
SAFEARRAY *psa = V_ISBYREF(pVariant) ? *V_ARRAYREF(pVariant)
: V_ARRAY(pVariant);
int dim = SafeArrayGetDim(psa);
/* convert 1-dim UI1 ARRAY to simple SvPV */
if (vt_base == VT_UI1 && dim == 1) {
char *pStr;
LONG lLower, lUpper;
SafeArrayGetLBound(psa, 1, &lLower);
SafeArrayGetUBound(psa, 1, &lUpper);
hr = SafeArrayAccessData(psa, (void**)&pStr);
if (SUCCEEDED(hr)) {
sv_setpvn(sv, pStr, lUpper-lLower+1);
SafeArrayUnaccessData(psa);
}
return hr;
}
AV **pav;
LONG *pArrayIndex, *pLowerBound, *pUpperBound;
New(0, pav, dim, AV*);
New(0, pArrayIndex, dim, LONG);
New(0, pLowerBound, dim, LONG);
New(0, pUpperBound, dim, LONG);
IV index;
for (index = 0; index < dim; ++index) {
pav[index] = newAV();
SafeArrayGetLBound(psa, (UINT)(index+1), &pLowerBound[index]);
SafeArrayGetUBound(psa, (UINT)(index+1), &pUpperBound[index]);
}
Copy(pLowerBound, pArrayIndex, dim, long);
hr = SafeArrayLock(psa);
if (SUCCEEDED(hr)) {
VARIANT variant;
VariantInit(&variant);
if (vt_base == VT_RECORD) {
hr = SafeArrayGetRecordInfo(psa, &V_RECORDINFO(&variant));
if (SUCCEEDED(hr))
V_VT(&variant) = VT_RECORD;
}
else
V_VT(&variant) = vt_base | VT_BYREF;
if (SUCCEEDED(hr)) {
while (index >= 0) {
if (vt_base == VT_RECORD)
hr = SafeArrayPtrOfIndex(psa, pArrayIndex, &V_RECORD(&variant));
else
hr = SafeArrayPtrOfIndex(psa, pArrayIndex, &V_BYREF(&variant));
if (FAILED(hr))
break;
SV *val = newSV(0);
hr = SetSVFromVariantEx(aTHX_ &variant, val, stash);
if (FAILED(hr)) {
SvREFCNT_dec(val);
break;
}
av_push(pav[dim-1], val);
for (index = dim-1; index >= 0; --index) {
if (++pArrayIndex[index] <= pUpperBound[index])
break;
pArrayIndex[index] = pLowerBound[index];
if (index > 0) {
av_push(pav[index-1], newRV_noinc((SV*)pav[index]));
pav[index] = newAV();
}
}
}
}
/* preserve previous error code */
HRESULT hr2 = SafeArrayUnlock(psa);
if (SUCCEEDED(hr))
hr = hr2;
}
for (index = 1; index < dim; ++index)
SvREFCNT_dec((SV*)pav[index]);
if (SUCCEEDED(hr))
sv_setsv(sv, sv_2mortal(newRV_noinc((SV*)*pav)));
else
SvREFCNT_dec((SV*)*pav);
Safefree(pArrayIndex);
Safefree(pLowerBound);
Safefree(pUpperBound);
Safefree(pav);
return hr;
}
switch (vt & ~VT_BYREF) {
case VT_VARIANT: /* invalid, should never happen */
case VT_EMPTY:
case VT_NULL:
/* return "undef" */
break;
case VT_UI1:
SET(iv, UI1);
break;
case VT_I2:
SET(iv, I2);
break;
case VT_I4:
SET(iv, I4);
break;
case VT_R4:
SET(nv, R4);
break;
case VT_R8:
SET(nv, R8);
break;
case VT_BSTR:
{
UINT cp = (UINT)QueryPkgVar(aTHX_ stash, CP_NAME, CP_LEN, cpDefault);
if (V_ISBYREF(pVariant))
sv_setbstr(aTHX_ sv, *V_BSTRREF(pVariant), cp);
else
sv_setbstr(aTHX_ sv, V_BSTR(pVariant), cp);
break;
}
case VT_ERROR:
case VT_DATE:
{
ConvertToVariant:
SV *classname;
WINOLEVARIANTOBJECT *pVarObj;
Newz(0, pVarObj, 1, WINOLEVARIANTOBJECT);
VariantInit(&pVarObj->variant);
VariantInit(&pVarObj->byref);
hr = VariantCopy(&pVarObj->variant, pVariant);
if (FAILED(hr)) {
Safefree(pVarObj);
break;
}
AddToObjectChain(aTHX_ (OBJECTHEADER*)pVarObj, WINOLEVARIANT_MAGIC);
classname = newSVpv(HvNAME(stash), 0);
sv_catpvn(classname, "::Variant", 9);
sv_setref_pv(sv, SvPVX(classname), pVarObj);
SvREFCNT_dec(classname);
break;
}
case VT_BOOL:
if (V_ISBYREF(pVariant))
sv_setiv(sv, *V_BOOLREF(pVariant) ? 1 : 0);
else
sv_setiv(sv, V_BOOL(pVariant) ? 1 : 0);
break;
case VT_DISPATCH:
{
IDispatch *pDispatch;
if (V_ISBYREF(pVariant))
pDispatch = *V_DISPATCHREF(pVariant);
else
pDispatch = V_DISPATCH(pVariant);
if (pDispatch) {
pDispatch->AddRef();
sv_setsv(sv, CreatePerlObject(aTHX_ stash, pDispatch, NULL));
}
break;
}
case VT_UNKNOWN:
{
IUnknown *punk;
IDispatch *pDispatch;
if (V_ISBYREF(pVariant))
punk = *V_UNKNOWNREF(pVariant);
else
punk = V_UNKNOWN(pVariant);
if (punk &&
SUCCEEDED(punk->QueryInterface(IID_IDispatch, (void**)&pDispatch)))
{
sv_setsv(sv, CreatePerlObject(aTHX_ stash, pDispatch, NULL));
}
break;
}
case VT_DECIMAL:
{
BOOL var = (BOOL)QueryPkgVar(aTHX_ stash, VAR_NAME, VAR_LEN, varDefault);
if (var)
goto ConvertToVariant;
VARIANT variant;
VariantInit(&variant);
hr = VariantChangeTypeEx(&variant, pVariant, lcidDefault, 0, VT_R8);
if (SUCCEEDED(hr) && V_VT(&variant) == VT_R8)
sv_setnv(sv, V_R8(&variant));
VariantClear(&variant);
break;
}
case VT_RECORD:
{
UINT cp = (UINT)QueryPkgVar(aTHX_ stash, CP_NAME, CP_LEN, cpDefault);
IRecordInfo *pinfo = V_RECORDINFO(pVariant);
void *pRecord = V_RECORD(pVariant);
ULONG count = 0;
hr = pinfo->GetFieldNames(&count, NULL);
if (FAILED(hr) || count == 0)
break;
BSTR *names;
Newz(0, names, count, BSTR);
hr = pinfo->GetFieldNames(&count, names);
if (FAILED(hr)) {
Safefree(names);
break;
}
HV *hv = newHV();
ULONG i;
for (i=0; i<count; ++i) {
VARIANT variant;
void *pData = NULL;
VariantInit(&variant);
hr = pinfo->GetFieldNoCopy(pRecord, names[i], &variant, &pData);
if (FAILED(hr))
break;
SV *value = newSV(0);
hr = SetSVFromVariantEx(aTHX_ &variant, value, stash, FALSE);
if (FAILED(hr)) {
SvREFCNT_dec(value);
break;
}
SV *name = sv_setbstr(aTHX_ NULL, names[i], cp);
hv_store_ent(hv, name, value, 0);
SvREFCNT_dec(name);
}
for (i=0; i<count; ++i)
SysFreeString(names[i]);
Safefree(names);
if (SUCCEEDED(hr))
sv_setsv(sv, sv_2mortal(newRV_noinc((SV*)hv)));
else
SvREFCNT_dec((SV*)hv);
break;
}
case VT_CY:
default:
{
BOOL var = (BOOL)QueryPkgVar(aTHX_ stash, VAR_NAME, VAR_LEN, varDefault);
if (var)
goto ConvertToVariant;
LCID lcid = (LCID)QueryPkgVar(aTHX_ stash, LCID_NAME, LCID_LEN, lcidDefault);
UINT cp = (UINT)QueryPkgVar(aTHX_ stash, CP_NAME, CP_LEN, cpDefault);
VARIANT variant;
VariantInit(&variant);
hr = VariantChangeTypeEx(&variant, pVariant, lcid, 0, VT_BSTR);
if (SUCCEEDED(hr) && V_VT(&variant) == VT_BSTR)
sv_setbstr(aTHX_ sv, V_BSTR(&variant), cp);
VariantClear(&variant);
break;
}
}
return hr;
# undef SET
} /* SetSVFromVariantEx */
HRESULT
SetSVFromVariant(pTHX_ VARIANTARG *pVariant, SV* sv, HV *stash)
{
return SetSVFromVariantEx(aTHX_ pVariant, sv, stash);
}
IV
GetLocaleNumber(pTHX_ HV *hv, char *key, LCID lcid, LCTYPE lctype)
{
if (hv) {
SV **psv = hv_fetch(hv, key, (I32)strlen(key), FALSE);
if (psv)
return SvIV(*psv);
}
IV number;
char *info;
int len = GetLocaleInfoA(lcid, lctype, NULL, 0);
New(0, info, len, char);
GetLocaleInfoA(lcid, lctype, info, len);
number = atol(info);
Safefree(info);
return number;
}
char *
GetLocaleString(pTHX_ HV *hv, char *key, LCID lcid, LCTYPE lctype)
{
if (hv) {
SV **psv = hv_fetch(hv, key, (I32)strlen(key), FALSE);
if (psv)
return SvPV_nolen(*psv);
}
int len = GetLocaleInfoA(lcid, lctype, NULL, 0);
SV *sv = sv_2mortal(newSV(len));
GetLocaleInfoA(lcid, lctype, SvPVX(sv), len);
return SvPVX(sv);
}
void
Initialize(pTHX_ HV *stash, DWORD dwCoInit=COINIT_MULTITHREADED)
{
dPERINTERP;
DBG(("Initialize\n"));
EnterCriticalSection(&g_CriticalSection);
if (!g_bInitialized)
{
HRESULT hr = S_OK;
g_pfnCoUninitialize = NULL;
g_bInitialized = TRUE;
DBG(("Initialize dwCoInit=%d\n", dwCoInit));
if (dwCoInit == COINIT_OLEINITIALIZE) {
hr = OleInitialize(NULL);
if (SUCCEEDED(hr))
g_pfnCoUninitialize = &OleUninitialize;
}
else if (dwCoInit != COINIT_NO_INITIALIZE) {
if (g_pfnCoInitializeEx)
hr = g_pfnCoInitializeEx(NULL, dwCoInit);
else
hr = CoInitialize(NULL);
if (SUCCEEDED(hr))
g_pfnCoUninitialize = &CoUninitialize;
}
if (FAILED(hr) && hr != RPC_E_CHANGED_MODE)
ReportOleError(aTHX_ stash, hr);
}
LeaveCriticalSection(&g_CriticalSection);
} /* Initialize */
void
Uninitialize(pTHX_ PERINTERP *pInterp)
{
DBG(("Uninitialize\n"));
EnterCriticalSection(&g_CriticalSection);
if (g_bInitialized) {
OBJECTHEADER *pHeader = g_pObj;
while (pHeader) {
DBG(("Zombiefy object |%lx| lMagic=%lx\n",
pHeader, pHeader->lMagic));
switch (pHeader->lMagic) {
case WINOLE_MAGIC:
ReleasePerlObject(aTHX_ (WINOLEOBJECT*)pHeader);
break;
case WINOLEENUM_MAGIC: {
WINOLEENUMOBJECT *pEnumObj = (WINOLEENUMOBJECT*)pHeader;
if (pEnumObj->pEnum) {
pEnumObj->pEnum->Release();
pEnumObj->pEnum = NULL;
}
break;
}
case WINOLEVARIANT_MAGIC: {
WINOLEVARIANTOBJECT *pVarObj = (WINOLEVARIANTOBJECT*)pHeader;
ClearVariantObject(pVarObj);
break;
}
case WINOLETYPELIB_MAGIC: {
WINOLETYPELIBOBJECT *pObj = (WINOLETYPELIBOBJECT*)pHeader;
if (pObj->pTypeLib) {
pObj->pTypeLib->Release();
pObj->pTypeLib = NULL;
}
break;
}
case WINOLETYPEINFO_MAGIC: {
WINOLETYPEINFOOBJECT *pObj = (WINOLETYPEINFOOBJECT*)pHeader;
if (pObj->pTypeInfo) {
pObj->pTypeInfo->Release();
pObj->pTypeInfo = NULL;
}
break;
}
default:
DBG(("Unknown magic number: %08lx", pHeader->lMagic));
break;
}
pHeader = pHeader->pNext;
}
DBG(("CoUninitialize\n"));
if (g_pfnCoUninitialize)
g_pfnCoUninitialize();
g_bInitialized = FALSE;
}
LeaveCriticalSection(&g_CriticalSection);
} /* Uninitialize */
static void
AtExit(pTHX_ void *pVoid)
{
PERINTERP *pInterp = (PERINTERP*)pVoid;
DeleteCriticalSection(&g_CriticalSection);
if (g_hOLE32)
FreeLibrary(g_hOLE32);
if (g_hHHCTRL)
FreeLibrary(g_hHHCTRL);
#ifdef PERL_IMPLICIT_CONTEXT
Safefree(pInterp);
#endif
DBG(("AtExit done\n"));
} /* AtExit */
void
Bootstrap(pTHX)
{
dSP;
#ifdef PERL_IMPLICIT_CONTEXT
PERINTERP *pInterp;
New(0, pInterp, 1, PERINTERP);
SV *sv = *hv_fetch(PL_modglobal, MY_VERSION, sizeof(MY_VERSION)-1, TRUE);
if (SvOK(sv))
warn(MY_VERSION ": Per-interpreter data already set");
sv_setiv(sv, PTR2IV(pInterp));
#endif
g_pObj = NULL;
g_bInitialized = FALSE;
g_hv_unique = newHV();
InitializeCriticalSection(&g_CriticalSection);
g_hOLE32 = LoadLibrary("OLE32");
g_pfnCoInitializeEx = NULL;
g_pfnCoCreateInstanceEx = NULL;
if (g_hOLE32) {
g_pfnCoInitializeEx = (FNCOINITIALIZEEX*)
GetProcAddress(g_hOLE32, "CoInitializeEx");
g_pfnCoCreateInstanceEx = (FNCOCREATEINSTANCEEX*)
GetProcAddress(g_hOLE32, "CoCreateInstanceEx");
}
g_hHHCTRL = NULL;
g_pfnHtmlHelp = NULL;
SV *cmd = newSVpv("", 0);
sv_setpvf(cmd, "END { %s->Uninitialize(%d); }", szWINOLE, WINOLE_MAGIC );
PUSHMARK(sp);
perl_eval_sv(cmd, G_DISCARD);
SPAGAIN;
SvREFCNT_dec(cmd);
perl_atexit(AtExit, INTERP);
} /* Bootstrap */
BOOL
CallObjectMethod(pTHX_ SV **mark, I32 ax, I32 items, char *pszMethod)
{
/* If the 1st arg on the stack is a Win32::OLE object then the method
* is called as an object method through Win32::OLE::Dispatch (like
* the AUTOLOAD does) and CallObjectMethod returns TRUE. In this case
* the caller should return immediately. Otherwise it should check the
* parameters on the stack and implement its class method functionality.
*/
dSP;
if (items == 0)
return FALSE;
if (!sv_isobject(ST(0)) || !sv_derived_from(ST(0), szWINOLE))
return FALSE;
SV *retval = sv_newmortal();
/* Dispatch must be called as: Dispatch($self,$method,$retval,@params),
* so move all stack entries after the object ref up to make room for
* the method name and return value.
*/
PUSHMARK(mark);
EXTEND(SP, 2);
for (I32 item = 1; item < items; ++item)
ST(2+items-item) = ST(items-item);
sp += 2;
ST(1) = sv_2mortal(newSVpv(pszMethod,0));
ST(2) = retval;
PUTBACK;
perl_call_method("Dispatch", G_DISCARD);
SPAGAIN;
PUSHs(retval);
PUTBACK;
return TRUE;
} /* CallObjectMethod */
} /* extern "C" */
/*##########################################################################*/
MODULE = Win32::OLE PACKAGE = Win32::OLE
PROTOTYPES: DISABLE
BOOT:
Bootstrap(aTHX);
void
Initialize(...)
ALIAS:
Uninitialize = 1
SpinMessageLoop = 2
MessageLoop = 3
QuitMessageLoop = 4
FreeUnusedLibraries = 5
_Unique = 6
PPCODE:
{
char *paszMethod[] = {"Initialize", "Uninitialize", "SpinMessageLoop",
"MessageLoop", "QuitMessageLoop",
"FreeUnusedLibraries", "_Unique"};
if (CallObjectMethod(aTHX_ mark, ax, items, paszMethod[ix]))
return;
DBG(("Win32::OLE->%s()\n", paszMethod[ix]));
if (items == 0) {
warn("Win32::OLE->%s must be called as class method", paszMethod[ix]);
XSRETURN_EMPTY;
}
HV *stash = gv_stashsv(ST(0), TRUE);
SetLastOleError(aTHX_ stash);
switch (ix) {
case 0: { // Initialize
DWORD dwCoInit = COINIT_MULTITHREADED;
if (items > 1 && SvOK(ST(1)))
dwCoInit = (DWORD)SvIV(ST(1));
Initialize(aTHX_ gv_stashsv(ST(0), TRUE), dwCoInit);
break;
}
case 1: { // Uninitialize
dPERINTERP;
Uninitialize(aTHX_ INTERP);
break;
}
case 2: // SpinMessageLoop
SpinMessageLoop();
break;
case 3: { // MessageLoop
MSG msg;
DBG(("MessageLoop\n"));
while (GetMessage(&msg, NULL, 0, 0)) {
if (msg.hwnd == NULL && msg.message == WM_USER)
break;
TranslateMessage(&msg);
DispatchMessage(&msg);
}
break;
}
case 4: // QuitMessageLoop
PostThreadMessage(GetCurrentThreadId(), WM_USER, 0, 0);
break;
case 5: // FreeUnusedLibraries
CoFreeUnusedLibraries();
break;
case 6: { // _Unique
dPERINTERP;
hv_undef(g_hv_unique);
break;
}
}
XSRETURN_EMPTY;
}
void
new(...)
PPCODE:
{
CLSID clsid;
IDispatch *pDispatch = NULL;
OLECHAR Buffer[OLE_BUF_SIZ];
OLECHAR *pBuffer;
HRESULT hr;
if (CallObjectMethod(aTHX_ mark, ax, items, "new"))
return;
if (items < 2 || items > 3) {
warn("Usage: Win32::OLE->new(PROGID[,DESTROY])");
XSRETURN_EMPTY;
}
SV *self = ST(0);
HV *stash = gv_stashsv(self, TRUE);
SV *progid = ST(1);
SV *destroy = NULL;
UINT cp = (UINT)QueryPkgVar(aTHX_ stash, CP_NAME, CP_LEN, cpDefault);
Initialize(aTHX_ stash);
SetLastOleError(aTHX_ stash);
if (items == 3)
destroy = CheckDestroyFunction(aTHX_ ST(2), "Win32::OLE->new");
ST(0) = &PL_sv_undef;
/* normal case: no DCOM */
if (!SvROK(progid) || SvTYPE(SvRV(progid)) != SVt_PVAV) {
pBuffer = GetWideChar(aTHX_ progid, Buffer, OLE_BUF_SIZ, cp);
if (StartsWithAlpha(aTHX_ progid))
hr = CLSIDFromProgID(pBuffer, &clsid);
else
hr = CLSIDFromString(pBuffer, &clsid);
ReleaseBuffer(aTHX_ pBuffer, Buffer);
if (SUCCEEDED(hr)) {
hr = CoCreateInstance(clsid, NULL, CLSCTX_SERVER,
IID_IDispatch, (void**)&pDispatch);
/* The tlbinf32.dll from Microsoft fails this call.
* It however supports instantiating an IUnknown interface
* and then querying that one for IDispatch...
*/
if (hr == E_NOINTERFACE) {
IUnknown *punk;
hr = CoCreateInstance(clsid, NULL, CLSCTX_SERVER,
IID_IUnknown, (void**)&punk);
if (SUCCEEDED(hr)) {
hr = punk->QueryInterface(IID_IDispatch, (void**)&pDispatch);
punk->Release();
}
}
}
if (!CheckOleError(aTHX_ stash, hr)) {
ST(0) = CreatePerlObject(aTHX_ stash, pDispatch, destroy);
DBG(("Win32::OLE::new |%lx| |%lx|\n", ST(0), pDispatch));
}
XSRETURN(1);
}
/* DCOM might not exist on Win95 (and does not on NT 3.5) */
dPERINTERP;
if (!g_pfnCoCreateInstanceEx) {
hr = HRESULT_FROM_WIN32(ERROR_SERVICE_DOES_NOT_EXIST);
ReportOleError(aTHX_ stash, hr);
XSRETURN(1);
}
/* DCOM spec: ['Servername', 'Program.ID'] */
AV *av = (AV*)SvRV(progid);
if (av_len(av) != 1) {
warn("Win32::OLE->new: for DCOM use ['Machine', 'Prog.Id']");
XSRETURN(1);
}
SV *host = *av_fetch(av, 0, FALSE);
progid = *av_fetch(av, 1, FALSE);
/* determine hostname */
if (SvPOK(host) && IsLocalMachine(aTHX_ host))
host = NULL;
/* determine CLSID */
pBuffer = GetWideChar(aTHX_ progid, Buffer, OLE_BUF_SIZ, cp);
if (StartsWithAlpha(aTHX_ progid)) {
hr = CLSIDFromProgID(pBuffer, &clsid);
if (FAILED(hr) && host)
hr = CLSIDFromRemoteRegistry(aTHX_ host, progid, &clsid);
}
else
hr = CLSIDFromString(pBuffer, &clsid);
ReleaseBuffer(aTHX_ pBuffer, Buffer);
if (FAILED(hr)) {
ReportOleError(aTHX_ stash, hr);
XSRETURN(1);
}
/* setup COSERVERINFO & MULTI_QI parameters */
DWORD clsctx = CLSCTX_REMOTE_SERVER;
COSERVERINFO ServerInfo;
OLECHAR ServerName[OLE_BUF_SIZ];
MULTI_QI multi_qi;
Zero(&ServerInfo, 1, COSERVERINFO);
if (host)
ServerInfo.pwszName = GetWideChar(aTHX_ host, ServerName,
OLE_BUF_SIZ, cp);
else
clsctx = CLSCTX_SERVER;
Zero(&multi_qi, 1, MULTI_QI);
multi_qi.pIID = &IID_IDispatch;
/* create instance on remote server */
hr = g_pfnCoCreateInstanceEx(clsid, NULL, clsctx, &ServerInfo,
1, &multi_qi);
ReleaseBuffer(aTHX_ ServerInfo.pwszName, ServerName);
if (!CheckOleError(aTHX_ stash, hr)) {
pDispatch = (IDispatch*)multi_qi.pItf;
ST(0) = CreatePerlObject(aTHX_ stash, pDispatch, destroy);
DBG(("Win32::OLE::new |%lx| |%lx|\n", ST(0), pDispatch));
}
XSRETURN(1);
}
void
DESTROY(self)
SV *self
PPCODE:
{
WINOLEOBJECT *pObj = GetOleObject(aTHX_ self, TRUE);
DBG(("Win32::OLE::DESTROY |%lx| |%lx|\n", pObj,
pObj ? pObj->pDispatch : NULL));
if (pObj) {
ReleasePerlObject(aTHX_ pObj);
pObj->flags |= OBJFLAG_DESTROYED;
}
XSRETURN_EMPTY;
}
void
Dispatch(self,method,retval,...)
SV *self
SV *method
SV *retval
PPCODE:
{
char *buffer = "";
size_t length;
unsigned int argErr;
unsigned int index;
I32 len;
WINOLEOBJECT *pObj;
EXCEPINFO excepinfo;
DISPID dispID = DISPID_VALUE;
DISPID dispIDParam = DISPID_PROPERTYPUT;
USHORT wFlags = DISPATCH_METHOD | DISPATCH_PROPERTYGET;
VARIANT result;
DISPPARAMS dispParams;
SV *curitem, *sv;
HE **rghe = NULL; /* named argument names */
SV *err = NULL; /* error details */
HRESULT hr = S_OK;
ST(0) = &PL_sv_no;
Zero(&excepinfo, 1, EXCEPINFO);
VariantInit(&result);
if (!sv_isobject(self)) {
warn("Win32::OLE::Dispatch: Cannot be called as class method");
DEBUGBREAK;
XSRETURN(1);
}
pObj = GetOleObject(aTHX_ self);
if (!pObj) {
XSRETURN(1);
}
HV *stash = SvSTASH(pObj->self);
SetLastOleError(aTHX_ stash);
LCID lcid = (LCID)QueryPkgVar(aTHX_ stash, LCID_NAME, LCID_LEN, lcidDefault);
UINT cp = (UINT)QueryPkgVar(aTHX_ stash, CP_NAME, CP_LEN, cpDefault);
/* allow [wFlags, 'Method'] instead of 'Method' */
if (SvROK(method) && (sv = SvRV(method)) && SvTYPE(sv) == SVt_PVAV &&
!SvOBJECT(sv) && av_len((AV*)sv) == 1)
{
wFlags = (USHORT)SvIV(*av_fetch((AV*)sv, 0, FALSE));
method = *av_fetch((AV*)sv, 1, FALSE);
}
if (SvIOK(method)) {
/* XXX this will NOT work with named parameters */
dispID = (DISPID)SvIV(method);
}
else if (SvPOK(method)) {
buffer = SvPV(method, length);
if (length > 0) {
int newenum = (int)QueryPkgVar(aTHX_ stash, _NEWENUM_NAME, _NEWENUM_LEN);
if (newenum && strEQ(buffer, "_NewEnum")) {
AV *av = newAV();
PUSHMARK(sp);
PUSHs(sv_2mortal(newSVpv(szWINOLEENUM, 0)));
PUSHs(self);
PUTBACK;
items = perl_call_method("All", G_ARRAY);
SPAGAIN;
for (index=0; index < (unsigned int)items; ++index)
av_push(av, newSVsv(ST(index)));
sv_setsv(retval, sv_2mortal(newRV_noinc((SV*)av)));
XSRETURN_YES;
}
hr = GetHashedDispID(aTHX_ pObj, method, dispID, lcid, cp);
if (FAILED(hr)) {
if (PL_hints & HINT_STRICT_SUBS) {
err = newSVpvf(" in GetIDsOfNames of \"%s\"", buffer);
ReportOleError(aTHX_ stash, hr, NULL, sv_2mortal(err));
}
XSRETURN_EMPTY;
}
}
}
DBG(("Dispatch \"%s\"\n", buffer));
dispParams.rgvarg = NULL;
dispParams.rgdispidNamedArgs = NULL;
dispParams.cNamedArgs = 0;
dispParams.cArgs = items - 3;
/* last arg is ref to a non-object-hash => named arguments */
curitem = ST(items-1);
if (SvROK(curitem) && (sv = SvRV(curitem)) &&
SvTYPE(sv) == SVt_PVHV && !SvOBJECT(sv))
{
if (wFlags & (DISPATCH_PROPERTYPUT|DISPATCH_PROPERTYPUTREF)) {
warn("Win32::OLE->Dispatch: named arguments not supported "
"for PROPERTYPUT");
DEBUGBREAK;
XSRETURN_EMPTY;
}
OLECHAR **rgszNames;
DISPID *rgdispids;
HV *hv = (HV*)sv;
dispParams.cNamedArgs = (UINT)HvKEYS(hv);
dispParams.cArgs += dispParams.cNamedArgs - 1;
New(0, rghe, dispParams.cNamedArgs, HE*);
New(0, dispParams.rgdispidNamedArgs, dispParams.cNamedArgs, DISPID);
New(0, dispParams.rgvarg, dispParams.cArgs, VARIANTARG);
for (index = 0; index < dispParams.cArgs; ++index)
VariantInit(&dispParams.rgvarg[index]);
New(0, rgszNames, 1+dispParams.cNamedArgs, OLECHAR*);
New(0, rgdispids, 1+dispParams.cNamedArgs, DISPID);
rgszNames[0] = AllocOleString(aTHX_ buffer, (int)length, cp);
hv_iterinit(hv);
for (index = 0; index < dispParams.cNamedArgs; ++index) {
rghe[index] = hv_iternext(hv);
char *pszName = hv_iterkey(rghe[index], &len);
rgszNames[1+index] = AllocOleString(aTHX_ pszName, len, cp);
}
hr = pObj->pDispatch->GetIDsOfNames(IID_NULL, rgszNames,
1+dispParams.cNamedArgs, lcid, rgdispids);
if (SUCCEEDED(hr)) {
for (index = 0; index < dispParams.cNamedArgs; ++index) {
dispParams.rgdispidNamedArgs[index] = rgdispids[index+1];
hr = SetVariantFromSVEx(aTHX_ hv_iterval(hv, rghe[index]),
&dispParams.rgvarg[index], cp, lcid);
if (FAILED(hr))
break;
}
}
else {
unsigned int cErrors = 0;
unsigned int error = 0;
for (index = 1; index <= dispParams.cNamedArgs; ++index)
if (rgdispids[index] == DISPID_UNKNOWN)
++cErrors;
err = sv_2mortal(newSVpv("",0));
for (index = 1; index <= dispParams.cNamedArgs; ++index)
if (rgdispids[index] == DISPID_UNKNOWN) {
if (error++ > 0)
sv_catpv(err, error == cErrors ? " and " : ", ");
sv_catpvf(err, "\"%s\"", hv_iterkey(rghe[index-1], &len));
}
sv_catpvf(err, " in GetIDsOfNames for \"%s\"", buffer);
}
for (index = 0; index <= dispParams.cNamedArgs; ++index)
SysFreeString(rgszNames[index]);
Safefree(rgszNames);
Safefree(rgdispids);
if (FAILED(hr))
goto Cleanup;
--items;
}
if (dispParams.cArgs > dispParams.cNamedArgs) {
if (!dispParams.rgvarg) {
New(0, dispParams.rgvarg, dispParams.cArgs, VARIANTARG);
for (index = 0; index < dispParams.cArgs; ++index)
VariantInit(&dispParams.rgvarg[index]);
}
for (index = dispParams.cNamedArgs; index < dispParams.cArgs; ++index) {
SV *sv = ST(items-1-(index-dispParams.cNamedArgs));
VARIANT *pVariant = &dispParams.rgvarg[index];
/* XXX requirement to call mg_get() may change in Perl > 5.005 */
MagicGet(aTHX_ sv);
if (SvOK(sv)) {
hr = SetVariantFromSVEx(aTHX_ sv, pVariant, cp, lcid);
if (FAILED(hr))
goto Cleanup;
}
else {
V_VT(pVariant) = VT_ERROR;
V_ERROR(pVariant) = DISP_E_PARAMNOTFOUND;
}
}
}
if (wFlags & (DISPATCH_PROPERTYPUT|DISPATCH_PROPERTYPUTREF)) {
Safefree(dispParams.rgdispidNamedArgs);
dispParams.rgdispidNamedArgs = &dispIDParam;
dispParams.cNamedArgs = 1;
}
hr = pObj->pDispatch->Invoke(dispID, IID_NULL, lcid, wFlags,
&dispParams, &result, &excepinfo, &argErr);
if (FAILED(hr)) {
/* mega kludge. if a method in WORD is called and we ask
* for a result when one is not returned then
* hResult == DISP_E_EXCEPTION. this only happens on
* functions whose DISPID > 0x8000 */
if (hr == DISP_E_EXCEPTION && dispID > 0x8000) {
Zero(&excepinfo, 1, EXCEPINFO);
hr = pObj->pDispatch->Invoke(dispID, IID_NULL, lcid, wFlags,
&dispParams, NULL, &excepinfo, &argErr);
}
}
if (SUCCEEDED(hr)) {
if (sv_isobject(retval) && sv_derived_from(retval, szWINOLEVARIANT)) {
WINOLEVARIANTOBJECT *pVarObj = GetOleVariantObject(aTHX_ retval);
if (pVarObj) {
ClearVariantObject(pVarObj);
MyVariantCopy(&pVarObj->variant, &result);
ST(0) = &PL_sv_yes;
}
}
else {
hr = SetSVFromVariantEx(aTHX_ &result, retval, stash);
if (SUCCEEDED(hr))
ST(0) = &PL_sv_yes;
}
}
if (FAILED(hr)) {
/* use more specific error code from exception when available */
if (hr == DISP_E_EXCEPTION && FAILED(excepinfo.scode))
hr = excepinfo.scode;
char *pszDelim = "";
err = sv_newmortal();
sv_setpvf(err, "in ");
if (wFlags&DISPATCH_METHOD) {
sv_catpv(err, "METHOD");
pszDelim = "/";
}
if (wFlags&DISPATCH_PROPERTYGET) {
sv_catpvf(err, "%sPROPERTYGET", pszDelim);
pszDelim = "/";
}
if (wFlags&DISPATCH_PROPERTYPUT) {
sv_catpvf(err, "%sPROPERTYPUT", pszDelim);
pszDelim = "/";
}
if (wFlags&DISPATCH_PROPERTYPUTREF)
sv_catpvf(err, "%sPROPERTYPUTREF", pszDelim);
sv_catpvf(err, " \"%s\"", buffer);
if (hr == DISP_E_TYPEMISMATCH || hr == DISP_E_PARAMNOTFOUND) {
if (rghe && argErr < dispParams.cNamedArgs)
sv_catpvf(err, " argument \"%s\"",
hv_iterkey(rghe[argErr], &len));
else
sv_catpvf(err, " argument %d", dispParams.cArgs - argErr);
}
}
Cleanup:
VariantClear(&result);
if (dispParams.cArgs != 0 && dispParams.rgvarg) {
for (index = 0; index < dispParams.cArgs; ++index)
VariantClear(&dispParams.rgvarg[index]);
Safefree(dispParams.rgvarg);
}
Safefree(rghe);
if (dispParams.rgdispidNamedArgs != &dispIDParam)
Safefree(dispParams.rgdispidNamedArgs);
CheckOleError(aTHX_ stash, hr, &excepinfo, err);
XSRETURN(1);
}
void
GetIDsOfNames(self, method)
SV *self
SV *method
PPCODE:
{
DISPID dispID;
WINOLEOBJECT *pObj = GetOleObject(aTHX_ self);
if (!pObj)
XSRETURN_EMPTY;
HV *stash = SvSTASH(pObj->self);
SetLastOleError(aTHX_ stash);
LCID lcid = (LCID)QueryPkgVar(aTHX_ stash, LCID_NAME, LCID_LEN, lcidDefault);
UINT cp = (UINT)QueryPkgVar(aTHX_ stash, CP_NAME, CP_LEN, cpDefault);
HRESULT hr = GetHashedDispID(aTHX_ pObj, method, dispID, lcid, cp);
if (FAILED(hr))
XSRETURN_EMPTY;
XSRETURN_IV(dispID);
}
void
EnumAllObjects(...)
PPCODE:
{
if (CallObjectMethod(aTHX_ mark, ax, items, "EnumAllObjects"))
return;
if (items > 2) {
warn("Usage: Win32::OLE->EnumAllObjects([CALLBACK])");
XSRETURN_EMPTY;
}
if (items == 2 && (!SvROK(ST(1)) || SvTYPE(SvRV(ST(1))) != SVt_PVCV)) {
warn(MY_VERSION "Win32::OLE->EnumAllObjects: "
"CALLBACK must be a CODE ref");
XSRETURN_EMPTY;
}
dPERINTERP;
IV count = 0;
OBJECTHEADER *pHeader = g_pObj;
SV *callback = (items == 2) ? ST(1) : NULL;
while (pHeader) {
if (pHeader->lMagic == WINOLE_MAGIC) {
++count;
if (callback) {
WINOLEOBJECT *pObj = (WINOLEOBJECT*)pHeader;;
SV *self = newRV_inc((SV*)pObj->self);
if (Gv_AMG(SvSTASH(pObj->self)))
SvAMAGIC_on(self);
ENTER;
SAVETMPS;
PUSHMARK(sp);
XPUSHs(sv_2mortal(self));
PUTBACK;
perl_call_sv(callback, G_DISCARD);
SPAGAIN;
FREETMPS;
LEAVE;
}
}
pHeader = pHeader->pNext;
}
XSRETURN_IV(count);
}
void
Forward(...)
PPCODE:
{
if (CallObjectMethod(aTHX_ mark, ax, items, "Forward"))
return;
if (items != 2) {
warn("Usage: Win32::OLE->Forward(METHOD)");
XSRETURN_EMPTY;
}
SV *self = ST(0);
SV *method = ST(1);
if (!SvROK(method) || SvTYPE(SvRV(method)) != SVt_PVCV) {
warn("Win32::OLE->Forward: method must be a CODE ref");
XSRETURN_EMPTY;
}
HV *stash = gv_stashsv(self, TRUE);
IDispatch *pDispatch = new Forwarder(aTHX_ stash, method);
ST(0) = CreatePerlObject(aTHX_ stash, pDispatch, NULL);
XSRETURN(1);
}
void
GetActiveObject(...)
PPCODE:
{
CLSID clsid;
OLECHAR Buffer[OLE_BUF_SIZ];
OLECHAR *pBuffer;
HRESULT hr;
IUnknown *pUnknown;
IDispatch *pDispatch;
if (CallObjectMethod(aTHX_ mark, ax, items, "GetActiveObject"))
return;
if (items < 2 || items > 3) {
warn("Usage: Win32::OLE->GetActiveObject(PROGID[,DESTROY])");
XSRETURN_EMPTY;
}
SV *self = ST(0);
HV *stash = gv_stashsv(self, TRUE);
SV *progid = ST(1);
SV *destroy = NULL;
UINT cp = (UINT)QueryPkgVar(aTHX_ stash, CP_NAME, CP_LEN, cpDefault);
Initialize(aTHX_ stash);
SetLastOleError(aTHX_ stash);
if (items == 3)
destroy = CheckDestroyFunction(aTHX_ ST(2),
"Win32::OLE->GetActiveObject");
pBuffer = GetWideChar(aTHX_ progid, Buffer, OLE_BUF_SIZ, cp);
if (isalpha(SvPV_nolen(progid)[0]))
hr = CLSIDFromProgID(pBuffer, &clsid);
else
hr = CLSIDFromString(pBuffer, &clsid);
ReleaseBuffer(aTHX_ pBuffer, Buffer);
if (CheckOleError(aTHX_ stash, hr))
XSRETURN_EMPTY;
hr = GetActiveObject(clsid, 0, &pUnknown);
/* Don't call CheckOleError! Return "undef" for "Server not running" */
if (FAILED(hr))
XSRETURN_EMPTY;
hr = pUnknown->QueryInterface(IID_IDispatch, (void**)&pDispatch);
pUnknown->Release();
if (CheckOleError(aTHX_ stash, hr))
XSRETURN_EMPTY;
ST(0) = CreatePerlObject(aTHX_ stash, pDispatch, destroy);
DBG(("Win32::OLE::GetActiveObject |%lx| |%lx|\n", ST(0), pDispatch));
XSRETURN(1);
}
void
GetObject(...)
PPCODE:
{
IBindCtx *pBindCtx;
IMoniker *pMoniker;
IDispatch *pDispatch;
OLECHAR Buffer[OLE_BUF_SIZ];
OLECHAR *pBuffer;
ULONG ulEaten;
HRESULT hr;
if (CallObjectMethod(aTHX_ mark, ax, items, "GetObject"))
return;
if (items < 2 || items > 3) {
warn("Usage: Win32::OLE->GetObject(PATHNAME[,DESTROY])");
XSRETURN_EMPTY;
}
SV *self = ST(0);
HV *stash = gv_stashsv(self, TRUE);
SV *pathname = ST(1);
SV *destroy = NULL;
UINT cp = (UINT)QueryPkgVar(aTHX_ stash, CP_NAME, CP_LEN, cpDefault);
Initialize(aTHX_ stash);
SetLastOleError(aTHX_ stash);
if (items == 3)
destroy = CheckDestroyFunction(aTHX_ ST(2), "Win32::OLE->GetObject");
hr = CreateBindCtx(0, &pBindCtx);
if (CheckOleError(aTHX_ stash, hr))
XSRETURN_EMPTY;
pBuffer = GetWideChar(aTHX_ pathname, Buffer, OLE_BUF_SIZ, cp);
hr = MkParseDisplayName(pBindCtx, pBuffer, &ulEaten, &pMoniker);
ReleaseBuffer(aTHX_ pBuffer, Buffer);
if (FAILED(hr)) {
pBindCtx->Release();
SV *sv = sv_newmortal();
sv_setpvf(sv, "after character %lu in \"%s\"", ulEaten, SvPV_nolen(pathname));
ReportOleError(aTHX_ stash, hr, NULL, sv);
XSRETURN_EMPTY;
}
hr = pMoniker->BindToObject(pBindCtx, NULL, IID_IDispatch,
(void**)&pDispatch);
pBindCtx->Release();
pMoniker->Release();
if (CheckOleError(aTHX_ stash, hr))
XSRETURN_EMPTY;
ST(0) = CreatePerlObject(aTHX_ stash, pDispatch, destroy);
XSRETURN(1);
}
void
GetTypeInfo(self)
SV *self
PPCODE:
{
WINOLEOBJECT *pObj = GetOleObject(aTHX_ self);
if (!pObj)
XSRETURN_EMPTY;
ITypeInfo *pTypeInfo;
TYPEATTR *pTypeAttr;
HV *stash = gv_stashsv(self, TRUE);
LCID lcid = (LCID)QueryPkgVar(aTHX_ stash, LCID_NAME, LCID_LEN, lcidDefault);
SetLastOleError(aTHX_ stash);
HRESULT hr = pObj->pDispatch->GetTypeInfo(0, lcid, &pTypeInfo);
if (CheckOleError(aTHX_ stash, hr))
XSRETURN_EMPTY;
hr = pTypeInfo->GetTypeAttr(&pTypeAttr);
if (FAILED(hr)) {
pTypeInfo->Release();
ReportOleError(aTHX_ stash, hr);
XSRETURN_EMPTY;
}
ST(0) = sv_2mortal(CreateTypeInfoObject(aTHX_ pTypeInfo, pTypeAttr));
XSRETURN(1);
}
void
QueryInterface(self,itf)
SV *self
SV *itf
PPCODE:
{
WINOLEOBJECT *pObj = GetOleObject(aTHX_ self);
if (!pObj)
XSRETURN_EMPTY;
IID iid;
// XXX support GUIDs in addition to names too
char *pszItf = SvPV_nolen(itf);
DBG(("QueryInterface(%s)\n", pszItf));
HV *stash = SvSTASH(pObj->self);
LCID lcid = (LCID)QueryPkgVar(aTHX_ stash, LCID_NAME, LCID_LEN, lcidDefault);
UINT cp = (UINT)QueryPkgVar(aTHX_ stash, CP_NAME, CP_LEN, cpDefault);
SetLastOleError(aTHX_ stash);
HRESULT hr = FindIID(aTHX_ pObj, pszItf, &iid, NULL, cp, lcid);
if (CheckOleError(aTHX_ stash, hr))
XSRETURN_EMPTY;
IUnknown *pUnknown;
hr = pObj->pDispatch->QueryInterface(iid, (void**)&pUnknown);
DBG((" QueryInterface(iid): 0x%08x\n", hr));
if (CheckOleError(aTHX_ stash, hr))
XSRETURN_EMPTY;
IDispatch *pDispatch;
hr = pUnknown->QueryInterface(IID_IDispatch, (void**)&pDispatch);
DBG((" QueryInterface(IDispatch): 0x%08x\n", hr));
pUnknown->Release();
if (CheckOleError(aTHX_ stash, hr))
XSRETURN_EMPTY;
ST(0) = CreatePerlObject(aTHX_ stash, pDispatch, NULL);
DBG(("Win32::OLE::QueryInterface |%lx| |%lx|\n", ST(0), pDispatch));
XSRETURN(1);
}
void
QueryObjectType(...)
PPCODE:
{
if (CallObjectMethod(aTHX_ mark, ax, items, "QueryObjectType"))
return;
if (items != 2) {
warn("Usage: Win32::OLE->QueryObjectType(OBJECT)");
XSRETURN_EMPTY;
}
SV *object = ST(1);
if (!sv_isobject(object) || !sv_derived_from(object, szWINOLE)) {
warn("Win32::OLE->QueryObjectType: object is not a Win32::OLE object");
XSRETURN_EMPTY;
}
WINOLEOBJECT *pObj = GetOleObject(aTHX_ object);
if (!pObj)
XSRETURN_EMPTY;
ITypeInfo *pTypeInfo;
ITypeLib *pTypeLib;
unsigned int count;
BSTR bstr;
HRESULT hr = pObj->pDispatch->GetTypeInfoCount(&count);
if (FAILED(hr) || count == 0)
XSRETURN_EMPTY;
HV *stash = gv_stashsv(ST(0), TRUE);
LCID lcid = (LCID)QueryPkgVar(aTHX_ stash, LCID_NAME, LCID_LEN, lcidDefault);
UINT cp = (UINT)QueryPkgVar(aTHX_ stash, CP_NAME, CP_LEN, cpDefault);
SetLastOleError(aTHX_ stash);
hr = pObj->pDispatch->GetTypeInfo(0, lcid, &pTypeInfo);
if (CheckOleError(aTHX_ stash, hr))
XSRETURN_EMPTY;
/* Return ('TypeLib Name', 'Class Name') in array context */
if (GIMME_V == G_ARRAY) {
hr = pTypeInfo->GetContainingTypeLib(&pTypeLib, &count);
if (FAILED(hr)) {
pTypeInfo->Release();
ReportOleError(aTHX_ stash, hr);
XSRETURN_EMPTY;
}
hr = pTypeLib->GetDocumentation(-1, &bstr, NULL, NULL, NULL);
pTypeLib->Release();
if (FAILED(hr)) {
pTypeInfo->Release();
ReportOleError(aTHX_ stash, hr);
XSRETURN_EMPTY;
}
PUSHs(sv_2mortal(sv_setbstr(aTHX_ NULL, bstr, cp)));
SysFreeString(bstr);
}
hr = pTypeInfo->GetDocumentation(MEMBERID_NIL, &bstr, NULL, NULL, NULL);
pTypeInfo->Release();
if (CheckOleError(aTHX_ stash, hr))
XSRETURN_EMPTY;
PUSHs(sv_2mortal(sv_setbstr(aTHX_ NULL, bstr, cp)));
SysFreeString(bstr);
}
void
WithEvents(...)
PPCODE:
{
if (CallObjectMethod(aTHX_ mark, ax, items, "WithEvents"))
return;
if (items < 2) {
warn("Usage: Win32::OLE->WithEvents(OBJECT [, HANDLER [, INTERFACE]])");
XSRETURN_EMPTY;
}
WINOLEOBJECT *pObj = GetOleObject(aTHX_ ST(1));
if (!pObj)
XSRETURN_EMPTY;
// disconnect previous event handler
if (pObj->pEventSink) {
pObj->pEventSink->Unadvise();
pObj->pEventSink = NULL;
}
if (items == 2)
XSRETURN_EMPTY;
SV *handler = ST(2);
HV *stash = SvSTASH(pObj->self);
// make sure we are running in a single threaded apartment
HRESULT hr = CoInitialize(NULL);
if (CheckOleError(aTHX_ stash, hr))
XSRETURN_EMPTY;
CoUninitialize();
LCID lcid = (LCID)QueryPkgVar(aTHX_ stash, LCID_NAME, LCID_LEN, lcidDefault);
UINT cp = (UINT)QueryPkgVar(aTHX_ stash, CP_NAME, CP_LEN, cpDefault);
SetLastOleError(aTHX_ stash);
IID iid;
ITypeInfo *pTypeInfo = NULL;
// Interfacename specified?
if (items > 3) {
SV *itf = ST(3);
if (sv_isobject(itf) && sv_derived_from(itf, szWINOLETYPEINFO)) {
WINOLETYPEINFOOBJECT *pObj = GetOleTypeInfoObject(aTHX_ itf);
if (!pObj)
XSRETURN_EMPTY;
if (pObj->pTypeAttr->typekind == TKIND_DISPATCH) {
iid = (IID)pObj->pTypeAttr->guid;
pTypeInfo = pObj->pTypeInfo;
pTypeInfo->AddRef();
}
else if (pObj->pTypeAttr->typekind == TKIND_COCLASS) {
// Enumerate all implemented types of the COCLASS
for (UINT i=0; i < pObj->pTypeAttr->cImplTypes; i++) {
int iFlags;
hr = pObj->pTypeInfo->GetImplTypeFlags(i, &iFlags);
DBG(("GetImplTypeFlags: hr=0x%08x i=%d iFlags=%d\n", hr, i, iFlags));
if (FAILED(hr))
continue;
// looking for the [default] [source]
// we just hope that it is a dispinterface :-)
if ((iFlags & IMPLTYPEFLAG_FDEFAULT) &&
(iFlags & IMPLTYPEFLAG_FSOURCE))
{
HREFTYPE hRefType = 0;
hr = pObj->pTypeInfo->GetRefTypeOfImplType(i, &hRefType);
DBG(("GetRefTypeOfImplType: hr=0x%08x\n", hr));
if (FAILED(hr))
continue;
hr = pObj->pTypeInfo->GetRefTypeInfo(hRefType, &pTypeInfo);
DBG(("GetRefTypeInfo: hr=0x%08x\n", hr));
if (SUCCEEDED(hr))
break;
}
}
// Now that would be a bad surprise, if we didn't find it, wouldn't it?
if (!pTypeInfo) {
if (SUCCEEDED(hr))
hr = E_UNEXPECTED;
}
else {
// Determine IID of default source interface
TYPEATTR *pTypeAttr;
hr = pTypeInfo->GetTypeAttr(&pTypeAttr);
if (SUCCEEDED(hr)) {
iid = pTypeAttr->guid;
pTypeInfo->ReleaseTypeAttr(pTypeAttr);
}
else
pTypeInfo->Release();
}
}
else {
XSRETURN_EMPTY; /* set hr instead XXX error message */
}
}
else { /* interface _not_ a Win32::OLE::TypeInfo object */
char *pszItf = SvPV_nolen(itf);
if (isalpha(pszItf[0]))
hr = FindIID(aTHX_ pObj, pszItf, &iid, &pTypeInfo, cp, lcid);
else {
OLECHAR Buffer[OLE_BUF_SIZ];
OLECHAR *pBuffer = GetWideChar(aTHX_ itf, Buffer, OLE_BUF_SIZ, cp);
hr = IIDFromString(pBuffer, &iid);
ReleaseBuffer(aTHX_ pBuffer, Buffer);
}
}
}
else
hr = FindDefaultSource(aTHX_ pObj, &iid, &pTypeInfo, cp, lcid);
if (CheckOleError(aTHX_ stash, hr))
XSRETURN_EMPTY;
// Get IConnectionPointContainer interface
IConnectionPointContainer *pContainer;
hr = pObj->pDispatch->QueryInterface(IID_IConnectionPointContainer,
(void**)&pContainer);
DBG(("QueryInterFace(IConnectionPointContainer): hr=0x%08x\n", hr));
if (FAILED(hr)) {
pTypeInfo->Release();
ReportOleError(aTHX_ stash, hr);
XSRETURN_EMPTY;
}
// Find default source connection point
IConnectionPoint *pConnectionPoint;
hr = pContainer->FindConnectionPoint(iid, &pConnectionPoint);
pContainer->Release();
DBG(("FindConnectionPoint: hr=0x%08x\n", hr));
if (FAILED(hr)) {
if (pTypeInfo)
pTypeInfo->Release();
ReportOleError(aTHX_ stash, hr);
XSRETURN_EMPTY;
}
// Connect our EventSink object to it
pObj->pEventSink = new EventSink(aTHX_ pObj, handler, iid, pTypeInfo);
hr = pObj->pEventSink->Advise(pConnectionPoint);
pConnectionPoint->Release();
DBG(("Advise: hr=0x%08x\n", hr));
if (FAILED(hr)) {
if (pTypeInfo)
pTypeInfo->Release();
pObj->pEventSink->Release();
pObj->pEventSink = NULL;
ReportOleError(aTHX_ stash, hr);
}
#ifdef _DEBUG
// Get IOleControl interface
IOleControl *pOleControl;
hr = pObj->pDispatch->QueryInterface(IID_IOleControl, (void**)&pOleControl);
DBG(("QueryInterface(IOleControl): 0x%08x\n", hr));
if (SUCCEEDED(hr)) {
pOleControl->FreezeEvents(TRUE);
pOleControl->FreezeEvents(FALSE);
pOleControl->Release();
}
#endif
XSRETURN_EMPTY;
}
##############################################################################
MODULE = Win32::OLE PACKAGE = Win32::OLE::Tie
void
DESTROY(self)
SV *self
PPCODE:
{
WINOLEOBJECT *pObj = GetOleObject(aTHX_ self, TRUE);
DBG(("Win32::OLE::Tie::DESTROY |%lx| |%lx|\n", pObj,
pObj ? pObj->pDispatch : NULL));
if (pObj) {
/* objects may be destroyed in the wrong order during global cleanup */
if (!(pObj->flags & OBJFLAG_DESTROYED)) {
DBG(("Win32::OLE::Tie::DESTROY: OLE object not yet destroyed\n"));
if (pObj->pDispatch) {
/* make sure the reference to the tied hash is still valid */
sv_unmagic((SV*)pObj->self, 'P');
sv_magic((SV*)pObj->self, self, 'P', Nullch, 0);
ReleasePerlObject(aTHX_ pObj);
}
/* untie hash because we free the object *right now* */
sv_unmagic((SV*)pObj->self, 'P');
}
RemoveFromObjectChain(aTHX_ (OBJECTHEADER*)pObj);
Safefree(pObj);
}
DBG(("End of Win32::OLE::Tie::DESTROY\n"));
XSRETURN_EMPTY;
}
void
Fetch(self,key,def)
SV *self
SV *key
SV *def
PPCODE:
{
char *buffer;
STRLEN length;
unsigned int argErr;
EXCEPINFO excepinfo;
DISPPARAMS dispParams;
VARIANT result;
VARIANTARG propName;
DISPID dispID = DISPID_VALUE;
HRESULT hr;
buffer = SvPV(key, length);
if (strEQ(buffer, PERL_OLE_ID)) {
DBG(("Win32::OLE::Tie::Fetch(0x%08x,'%s')\n", self, buffer));
ST(0) = *hv_fetch((HV*)SvRV(self), PERL_OLE_ID, PERL_OLE_IDLEN, 0);
XSRETURN(1);
}
WINOLEOBJECT *pObj = GetOleObject(aTHX_ self);
DBG(("Win32::OLE::Tie::Fetch(0x%08x,'%s')\n", pObj, buffer));
if (!pObj)
XSRETURN_EMPTY;
HV *stash = SvSTASH(pObj->self);
SetLastOleError(aTHX_ stash);
ST(0) = &PL_sv_undef;
VariantInit(&result);
VariantInit(&propName);
LCID lcid = (LCID)QueryPkgVar(aTHX_ stash, LCID_NAME, LCID_LEN, lcidDefault);
UINT cp = (UINT)QueryPkgVar(aTHX_ stash, CP_NAME, CP_LEN, cpDefault);
dispParams.cArgs = 0;
dispParams.rgvarg = NULL;
dispParams.cNamedArgs = 0;
dispParams.rgdispidNamedArgs = NULL;
hr = GetHashedDispID(aTHX_ pObj, key, dispID, lcid, cp);
if (FAILED(hr)) {
if (!SvTRUE(def)) {
SV *err = newSVpvf(" in GetIDsOfNames \"%s\"", buffer);
ReportOleError(aTHX_ stash, hr, NULL, sv_2mortal(err));
XSRETURN(1);
}
/* default method call: $self->{Key} ---> $self->Item('Key') */
V_VT(&propName) = VT_BSTR;
V_BSTR(&propName) = AllocOleStringFromSV(aTHX_ key, cp);
dispParams.cArgs = 1;
dispParams.rgvarg = &propName;
}
Zero(&excepinfo, 1, EXCEPINFO);
hr = pObj->pDispatch->Invoke(dispID, IID_NULL,
lcid, DISPATCH_METHOD | DISPATCH_PROPERTYGET,
&dispParams, &result, &excepinfo, &argErr);
VariantClear(&propName);
if (FAILED(hr)) {
SV *sv = sv_newmortal();
sv_setpvf(sv, "in METHOD/PROPERTYGET \"%s\"", buffer);
VariantClear(&result);
ReportOleError(aTHX_ stash, hr, &excepinfo, sv);
}
else {
ST(0) = sv_newmortal();
hr = SetSVFromVariantEx(aTHX_ &result, ST(0), stash);
VariantClear(&result);
CheckOleError(aTHX_ stash, hr);
}
XSRETURN(1);
}
void
Store(self,key,value,def)
SV *self
SV *key
SV *value
SV *def
PPCODE:
{
unsigned int argErr;
STRLEN length;
char *buffer;
unsigned int index;
HRESULT hr;
EXCEPINFO excepinfo;
DISPID dispID = DISPID_VALUE;
DISPID dispIDParam = DISPID_PROPERTYPUT;
DISPPARAMS dispParams;
VARIANTARG propertyValue[2];
SV *err = NULL;
WINOLEOBJECT *pObj = GetOleObject(aTHX_ self);
if (!pObj)
XSRETURN_EMPTY;
HV *stash = SvSTASH(pObj->self);
SetLastOleError(aTHX_ stash);
LCID lcid = (LCID)QueryPkgVar(aTHX_ stash, LCID_NAME, LCID_LEN, lcidDefault);
UINT cp = (UINT)QueryPkgVar(aTHX_ stash, CP_NAME, CP_LEN, cpDefault);
dispParams.rgdispidNamedArgs = &dispIDParam;
dispParams.rgvarg = propertyValue;
dispParams.cNamedArgs = 1;
dispParams.cArgs = 1;
VariantInit(&propertyValue[0]);
VariantInit(&propertyValue[1]);
Zero(&excepinfo, 1, EXCEPINFO);
buffer = SvPV(key, length);
hr = GetHashedDispID(aTHX_ pObj, key, dispID, lcid, cp);
if (FAILED(hr)) {
if (!SvTRUE(def)) {
SV *err = newSVpvf(" in GetIDsOfNames \"%s\"", buffer);
ReportOleError(aTHX_ stash, hr, NULL, sv_2mortal(err));
XSRETURN_EMPTY;
}
dispParams.cArgs = 2;
V_VT(&propertyValue[1]) = VT_BSTR;
V_BSTR(&propertyValue[1]) = AllocOleStringFromSV(aTHX_ key, cp);
}
hr = SetVariantFromSVEx(aTHX_ value, &propertyValue[0], cp, lcid);
if (SUCCEEDED(hr)) {
USHORT wFlags = DISPATCH_PROPERTYPUT;
/* objects are passed by reference */
VARTYPE vt = V_VT(&propertyValue[0]) & VT_TYPEMASK;
if (vt == VT_DISPATCH || vt == VT_UNKNOWN)
wFlags = DISPATCH_PROPERTYPUTREF;
hr = pObj->pDispatch->Invoke(dispID, IID_NULL, lcid, wFlags,
&dispParams, NULL, &excepinfo, &argErr);
if (FAILED(hr)) {
err = sv_newmortal();
sv_setpvf(err, "in PROPERTYPUT%s \"%s\"",
(wFlags == DISPATCH_PROPERTYPUTREF ? "REF" : ""), buffer);
}
}
for (index = 0; index < dispParams.cArgs; ++index)
VariantClear(&propertyValue[index]);
if (CheckOleError(aTHX_ stash, hr, &excepinfo, err))
XSRETURN_EMPTY;
XSRETURN_YES;
}
void
FIRSTKEY(self,...)
SV *self
ALIAS:
NEXTKEY = 1
FIRSTENUM = 2
NEXTENUM = 3
PPCODE:
{
/* NEXTKEY has an additional "lastkey" arg, which is not needed here */
WINOLEOBJECT *pObj = GetOleObject(aTHX_ self);
char *paszMethod[] = {"FIRSTKEY", "NEXTKEY", "FIRSTENUM", "NEXTENUM"};
DBG(("%s called, pObj=%p\n", paszMethod[ix], pObj));
if (!pObj)
XSRETURN_EMPTY;
HV *stash = SvSTASH(pObj->self);
SetLastOleError(aTHX_ stash);
SV *sv = NULL;
switch (ix) {
case 0: /* FIRSTKEY */
FetchTypeInfo(aTHX_ pObj);
pObj->PropIndex = 0;
case 1: /* NEXTKEY */
sv = NextPropertyName(aTHX_ pObj);
break;
case 2: /* FIRSTENUM */
if (pObj->pEnum)
pObj->pEnum->Release();
pObj->pEnum = CreateEnumVARIANT(aTHX_ pObj);
case 3: /* NEXTENUM */
sv = NextEnumElement(aTHX_ pObj->pEnum, stash);
if (!sv) {
pObj->pEnum->Release();
pObj->pEnum = NULL;
}
break;
}
if (!sv)
sv = &PL_sv_undef;
else if (!SvIMMORTAL(sv))
sv_2mortal(sv);
ST(0) = sv;
XSRETURN(1);
}
##############################################################################
MODULE = Win32::OLE PACKAGE = Win32::OLE::Const
void
_LoadRegTypeLib(classid,major,minor,locale,typelib,codepage)
SV *classid
IV major
IV minor
SV *locale
SV *typelib
SV *codepage
PPCODE:
{
ITypeLib *pTypeLib;
TLIBATTR *pTLibAttr;
CLSID clsid;
OLECHAR Buffer[OLE_BUF_SIZ];
OLECHAR *pBuffer;
HRESULT hr;
LCID lcid = SvIOK(locale) ? (LCID)SvIV(locale) : lcidDefault;
UINT cp = SvIOK(codepage) ? (UINT)SvIV(codepage) : cpDefault;
HV *stash = gv_stashpv(szWINOLE, TRUE);
Initialize(aTHX_ stash);
SetLastOleError(aTHX_ stash);
pBuffer = GetWideChar(aTHX_ classid, Buffer, OLE_BUF_SIZ, cp);
hr = CLSIDFromString(pBuffer, &clsid);
ReleaseBuffer(aTHX_ pBuffer, Buffer);
if (CheckOleError(aTHX_ stash, hr))
XSRETURN_EMPTY;
hr = LoadRegTypeLib(clsid, (USHORT)major, (USHORT)minor, lcid, &pTypeLib);
if (FAILED(hr) && SvPOK(typelib)) {
/* typelib not registerd, try to read from file "typelib" */
pBuffer = GetWideChar(aTHX_ typelib, Buffer, OLE_BUF_SIZ, cp);
hr = LoadTypeLibEx(pBuffer, REGKIND_NONE, &pTypeLib);
ReleaseBuffer(aTHX_ pBuffer, Buffer);
}
if (CheckOleError(aTHX_ stash, hr))
XSRETURN_EMPTY;
hr = pTypeLib->GetLibAttr(&pTLibAttr);
if (FAILED(hr)) {
pTypeLib->Release();
ReportOleError(aTHX_ stash, hr);
XSRETURN_EMPTY;
}
ST(0) = sv_2mortal(CreateTypeLibObject(aTHX_ pTypeLib, pTLibAttr));
XSRETURN(1);
}
void
_Constants(typelib,caller)
SV *typelib
SV *caller
PPCODE:
{
HRESULT hr;
UINT cp = cpDefault;
HV *stash = gv_stashpv(szWINOLE, TRUE);
HV *hv;
unsigned int count;
WINOLETYPELIBOBJECT *pObj = GetOleTypeLibObject(aTHX_ typelib);
if (!pObj)
XSRETURN_EMPTY;
if (SvOK(caller)) {
/* we'll define inlineable functions returning a const */
hv = gv_stashsv(caller, TRUE);
ST(0) = &PL_sv_undef;
}
else {
/* we'll return ref to hash with constant name => value pairs */
hv = newHV();
ST(0) = sv_2mortal(newRV_noinc((SV*)hv));
}
/* loop through all objects in type lib */
count = pObj->pTypeLib->GetTypeInfoCount();
for (unsigned int index=0; index < count; ++index) {
ITypeInfo *pTypeInfo;
TYPEATTR *pTypeAttr;
hr = pObj->pTypeLib->GetTypeInfo(index, &pTypeInfo);
if (CheckOleError(aTHX_ stash, hr))
continue;
hr = pTypeInfo->GetTypeAttr(&pTypeAttr);
if (FAILED(hr)) {
pTypeInfo->Release();
ReportOleError(aTHX_ stash, hr);
continue;
}
if (!(pTypeAttr->wTypeFlags & (TYPEFLAG_FHIDDEN |
TYPEFLAG_FRESTRICTED)))
{
for (int iVar=0; iVar < pTypeAttr->cVars; ++iVar) {
VARDESC *pVarDesc;
hr = pTypeInfo->GetVarDesc(iVar, &pVarDesc);
/* XXX LEAK alert */
if (CheckOleError(aTHX_ stash, hr))
continue;
if (pVarDesc->varkind == VAR_CONST &&
!(pVarDesc->wVarFlags & (VARFLAG_FHIDDEN |
VARFLAG_FRESTRICTED |
VARFLAG_FNONBROWSABLE)))
{
unsigned int cName;
BSTR bstr;
char szName[64];
hr = pTypeInfo->GetNames(pVarDesc->memid, &bstr, 1, &cName);
if (CheckOleError(aTHX_ stash, hr) || cName == 0 || !bstr)
continue;
char *pszName = GetMultiByte(aTHX_ bstr, szName, sizeof(szName), cp);
SV *sv = newSV(0);
/* XXX LEAK alert */
hr = SetSVFromVariantEx(aTHX_ pVarDesc->lpvarValue,
sv, stash);
if (!CheckOleError(aTHX_ stash, hr)) {
if (SvOK(caller)) {
/* XXX check for valid symbol name */
newCONSTSUB(hv, pszName, sv);
}
else
hv_store(hv, pszName, (I32)strlen(pszName), sv, 0);
}
SysFreeString(bstr);
ReleaseBuffer(aTHX_ pszName, szName);
}
pTypeInfo->ReleaseVarDesc(pVarDesc);
}
}
pTypeInfo->ReleaseTypeAttr(pTypeAttr);
pTypeInfo->Release();
}
XSRETURN(1);
}
void
_Typelibs(self,typelib)
SV *self
SV *typelib
PPCODE:
{
HKEY hKeyTypelib;
FILETIME ft;
LONG err = RegOpenKeyExA(HKEY_CLASSES_ROOT, SvPV_nolen(typelib),
0, KEY_READ, &hKeyTypelib);
if (err != ERROR_SUCCESS)
XSRETURN_NO;
EXTEND(SP, 5);
// Enumerate all Clsids
for (DWORD dwClsid=0;; ++dwClsid) {
HKEY hKeyClsid;
char szClsid[200];
DWORD cbClsid = sizeof(szClsid);
err = RegEnumKeyExA(hKeyTypelib, dwClsid, szClsid, &cbClsid,
NULL, NULL, NULL, &ft);
if (err != ERROR_SUCCESS)
break;
err = RegOpenKeyExA(hKeyTypelib, szClsid, 0, KEY_READ, &hKeyClsid);
if (err != ERROR_SUCCESS)
continue;
// Enumerate versions for current clsid
for (DWORD dwVersion=0;; ++dwVersion) {
HKEY hKeyVersion;
char szVersion[20];
DWORD cbVersion = sizeof(szVersion);
err = RegEnumKeyExA(hKeyClsid, dwVersion, szVersion, &cbVersion,
NULL, NULL, NULL, &ft);
if (err != ERROR_SUCCESS)
break;
err = RegOpenKeyExA(hKeyClsid, szVersion, 0, KEY_READ, &hKeyVersion);
if (err != ERROR_SUCCESS)
continue;
char szTitle[600];
LONG cbTitle = sizeof(szTitle);
err = RegQueryValueA(hKeyVersion, NULL, szTitle, &cbTitle);
if (err != ERROR_SUCCESS || cbTitle <= 1)
continue;
// Enumerate languages
for (DWORD dwLangid=0;; ++dwLangid) {
char szLangid[20];
DWORD cbLangid = sizeof(szLangid);
err = RegEnumKeyExA(hKeyVersion, dwLangid, szLangid, &cbLangid,
NULL, NULL, NULL, &ft);
if (err != ERROR_SUCCESS)
break;
// Language ids must be strictly numeric
char *psz=szLangid;
while (isDIGIT(*psz))
++psz;
if (*psz)
continue;
HKEY hKeyLangid;
err = RegOpenKeyExA(hKeyVersion, szLangid, 0, KEY_READ,
&hKeyLangid);
if (err != ERROR_SUCCESS)
continue;
// Retrieve filename of type library
char szFile[MAX_PATH+1];
LONG cbFile = sizeof(szFile);
err = RegQueryValueA(hKeyLangid, "win32", szFile, &cbFile);
if (err == ERROR_SUCCESS && cbFile > 1) {
ENTER;
SAVETMPS;
PUSHMARK(SP);
PUSHs(sv_2mortal(newSVpv(szClsid, cbClsid)));
PUSHs(sv_2mortal(newSVpv(szTitle, cbTitle-1)));
PUSHs(sv_2mortal(newSVpv(szVersion, cbVersion)));
PUSHs(sv_2mortal(newSVpv(szLangid, cbLangid)));
PUSHs(sv_2mortal(newSVpv(szFile, cbFile-1)));
PUTBACK;
perl_call_pv("Win32::OLE::Const::_Typelib", G_DISCARD);
SPAGAIN;
FREETMPS;
LEAVE;
}
RegCloseKey(hKeyLangid);
}
RegCloseKey(hKeyVersion);
}
RegCloseKey(hKeyClsid);
}
RegCloseKey(hKeyTypelib);
XSRETURN_YES;
}
void
_ShowHelpContext(helpfile,context)
char *helpfile
IV context
PPCODE:
{
HWND hwnd;
dPERINTERP;
if (!g_hHHCTRL) {
g_hHHCTRL = LoadLibrary("HHCTRL.OCX");
if (g_hHHCTRL)
g_pfnHtmlHelp = (FNHTMLHELP*)GetProcAddress(g_hHHCTRL, "HtmlHelpA");
}
if (!g_pfnHtmlHelp) {
warn(MY_VERSION ": HtmlHelp control unavailable");
XSRETURN_EMPTY;
}
// HH_HELP_CONTEXT 0x0F: display mapped numeric value in dwData
hwnd = g_pfnHtmlHelp(GetDesktopWindow(), helpfile, 0x0f, (DWORD)context);
if (hwnd == 0 && context == 0) // try HH_DISPLAY_TOPIC 0x0
g_pfnHtmlHelp(GetDesktopWindow(), helpfile, 0, (DWORD)context);
}
##############################################################################
MODULE = Win32::OLE PACKAGE = Win32::OLE::Enum
void
new(self,object)
SV *self
SV *object
ALIAS:
Clone = 1
PPCODE:
{
WINOLEENUMOBJECT *pEnumObj;
New(0, pEnumObj, 1, WINOLEENUMOBJECT);
if (ix == 0) { /* new */
WINOLEOBJECT *pObj = GetOleObject(aTHX_ object);
if (pObj) {
HV *olestash = GetWin32OleStash(aTHX_ object);
SetLastOleError(aTHX_ olestash);
pEnumObj->pEnum = CreateEnumVARIANT(aTHX_ pObj);
}
}
else { /* Clone */
WINOLEENUMOBJECT *pOriginal = GetOleEnumObject(aTHX_ self);
if (pOriginal) {
HV *olestash = GetWin32OleStash(aTHX_ self);
SetLastOleError(aTHX_ olestash);
HRESULT hr = pOriginal->pEnum->Clone(&pEnumObj->pEnum);
CheckOleError(aTHX_ olestash, hr);
}
}
if (!pEnumObj->pEnum) {
Safefree(pEnumObj);
XSRETURN_EMPTY;
}
AddToObjectChain(aTHX_ (OBJECTHEADER*)pEnumObj, WINOLEENUM_MAGIC);
SV *sv = newSViv(PTR2IV(pEnumObj));
ST(0) = sv_2mortal(sv_bless(newRV_noinc(sv), GetStash(aTHX_ self)));
XSRETURN(1);
}
void
DESTROY(self)
SV *self
PPCODE:
{
WINOLEENUMOBJECT *pEnumObj = GetOleEnumObject(aTHX_ self, TRUE);
if (pEnumObj) {
RemoveFromObjectChain(aTHX_ (OBJECTHEADER*)pEnumObj);
if (pEnumObj->pEnum)
pEnumObj->pEnum->Release();
Safefree(pEnumObj);
}
XSRETURN_EMPTY;
}
void
All(self,...)
SV *self
ALIAS:
Next = 1
PPCODE:
{
int count = 1;
if (ix == 0) { /* All */
/* my @list = Win32::OLE::Enum->All($Excel->Workbooks); */
if (!sv_isobject(self) && items > 1) {
/* $self = $self->new(shift); */
SV *obj = ST(1);
PUSHMARK(sp);
PUSHs(self);
PUSHs(obj);
PUTBACK;
items = perl_call_method("new", G_SCALAR);
SPAGAIN;
if (items == 1)
self = POPs;
PUTBACK;
}
}
else { /* Next */
if (items > 1)
count = (int)SvIV(ST(1));
if (count < 1) {
warn(MY_VERSION ": Win32::OLE::Enum::Next: invalid Count %ld",
count);
DEBUGBREAK;
count = 1;
}
}
WINOLEENUMOBJECT *pEnumObj = GetOleEnumObject(aTHX_ self);
if (!pEnumObj)
XSRETURN_EMPTY;
HV *olestash = GetWin32OleStash(aTHX_ self);
SetLastOleError(aTHX_ olestash);
while (ix == 0 || count-- > 0) {
SV *sv = NextEnumElement(aTHX_ pEnumObj->pEnum, olestash);
if (!sv)
break;
if (!SvIMMORTAL(sv))
sv_2mortal(sv);
XPUSHs(sv);
}
}
void
Reset(self)
SV *self
PPCODE:
{
WINOLEENUMOBJECT *pEnumObj = GetOleEnumObject(aTHX_ self);
if (!pEnumObj)
XSRETURN_NO;
HV *olestash = GetWin32OleStash(aTHX_ self);
SetLastOleError(aTHX_ olestash);
HRESULT hr = pEnumObj->pEnum->Reset();
CheckOleError(aTHX_ olestash, hr);
ST(0) = boolSV(hr == S_OK);
XSRETURN(1);
}
void
Skip(self,...)
SV *self
PPCODE:
{
WINOLEENUMOBJECT *pEnumObj = GetOleEnumObject(aTHX_ self);
if (!pEnumObj)
XSRETURN_NO;
HV *olestash = GetWin32OleStash(aTHX_ self);
SetLastOleError(aTHX_ olestash);
int count = (items > 1) ? (int)SvIV(ST(1)) : 1;
HRESULT hr = pEnumObj->pEnum->Skip(count);
CheckOleError(aTHX_ olestash, hr);
ST(0) = boolSV(hr == S_OK);
XSRETURN(1);
}
##############################################################################
MODULE = Win32::OLE PACKAGE = Win32::OLE::Variant
void
new(self,...)
SV *self
PPCODE:
{
HRESULT hr;
WINOLEVARIANTOBJECT *pVarObj;
VARTYPE vt = items < 2 ? VT_EMPTY : (VARTYPE)SvIV(ST(1));
SV *data = items < 3 ? Nullsv : ST(2);
// XXX Initialize should be superfluous here
// Initialize();
HV *olestash = GetWin32OleStash(aTHX_ self);
SetLastOleError(aTHX_ olestash);
VARTYPE vt_base = vt & VT_TYPEMASK;
if (!data && vt_base != VT_NULL && vt_base != VT_EMPTY &&
vt_base != VT_BSTR && vt_base != VT_DISPATCH && vt_base != VT_VARIANT)
{
warn(MY_VERSION ": Win32::OLE::Variant->new(vt, data): data may be"
" omitted only for VT_NULL, VT_EMPTY, VT_BSTR,"
" VT_DISPATCH or VT_VARIANT");
XSRETURN_EMPTY;
}
Newz(0, pVarObj, 1, WINOLEVARIANTOBJECT);
VARIANT *pVariant = &pVarObj->variant;
VariantInit(pVariant);
VariantInit(&pVarObj->byref);
V_VT(pVariant) = vt;
if (vt & VT_BYREF) {
if ((vt & ~VT_BYREF) == VT_VARIANT)
V_VARIANTREF(pVariant) = &pVarObj->byref;
else
V_BYREF(pVariant) = &V_UI1(&pVarObj->byref);
}
if (vt & VT_ARRAY) {
UINT cDims = items - 2;
SAFEARRAYBOUND *rgsabound;
SV *sv = ST(items-1);
if (cDims == 0) {
warn(MY_VERSION ": Win32::OLE::Variant->new() VT_ARRAY but "
"no array dimensions specified");
Safefree(pVarObj);
XSRETURN_EMPTY;
}
Newz(0, rgsabound, cDims, SAFEARRAYBOUND);
for (unsigned int iDim=0; iDim < cDims; ++iDim) {
SV *sv = ST(2+iDim);
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV) {
AV *av = (AV*)SvRV(sv);
SV **elt = av_fetch(av, 0, FALSE);
if (elt)
rgsabound[iDim].lLbound = (LONG)SvIV(*elt);
rgsabound[iDim].cElements = 1;
elt = av_fetch(av, 1, FALSE);
if (elt)
rgsabound[iDim].cElements +=
(ULONG)(SvIV(*elt) - rgsabound[iDim].lLbound);
}
else
rgsabound[iDim].cElements = (ULONG)SvIV(sv);
}
SAFEARRAY *psa = SafeArrayCreate(vt_base, cDims, rgsabound);
Safefree(rgsabound);
if (!psa) {
/* XXX No HRESULT value available */
warn(MY_VERSION ": Win32::OLE::Variant->new() couldnot "
"allocate SafeArray");
Safefree(pVarObj);
XSRETURN_EMPTY;
}
if (vt & VT_BYREF)
*V_ARRAYREF(pVariant) = psa;
else
V_ARRAY(pVariant) = psa;
}
else if (vt == VT_UI1 && SvPOK(data)) {
/* Special case: VT_UI1 with string implies VT_ARRAY */
unsigned char* pDest;
STRLEN len;
char *ptr = SvPV(data, len);
V_ARRAY(pVariant) = SafeArrayCreateVector(VT_UI1, 0, (ULONG)len);
if (V_ARRAY(pVariant)) {
V_VT(pVariant) = VT_UI1 | VT_ARRAY;
hr = SafeArrayAccessData(V_ARRAY(pVariant), (void**)&pDest);
if (FAILED(hr)) {
VariantClear(pVariant);
ReportOleError(aTHX_ olestash, hr);
}
else {
memcpy(pDest, ptr, len);
SafeArrayUnaccessData(V_ARRAY(pVariant));
}
}
}
else {
UINT cp = (UINT)QueryPkgVar(aTHX_ olestash, CP_NAME, CP_LEN, cpDefault);
LCID lcid = (LCID)QueryPkgVar(aTHX_ olestash, LCID_NAME, LCID_LEN,
lcidDefault);
hr = AssignVariantFromSV(aTHX_ data, pVariant, cp, lcid);
if (FAILED(hr)) {
Safefree(pVarObj);
ReportOleError(aTHX_ olestash, hr);
XSRETURN_EMPTY;
}
}
AddToObjectChain(aTHX_ (OBJECTHEADER*)pVarObj, WINOLEVARIANT_MAGIC);
HV *stash = GetStash(aTHX_ self);
SV *sv = newSViv(PTR2IV(pVarObj));
ST(0) = sv_2mortal(sv_bless(newRV_noinc(sv), stash));
XSRETURN(1);
}
void
DESTROY(self)
SV *self
PPCODE:
{
WINOLEVARIANTOBJECT *pVarObj = GetOleVariantObject(aTHX_ self);
if (pVarObj) {
RemoveFromObjectChain(aTHX_ (OBJECTHEADER*)pVarObj);
ClearVariantObject(pVarObj);
Safefree(pVarObj);
}
XSRETURN_EMPTY;
}
void
As(self,type)
SV *self
IV type
PPCODE:
{
WINOLEVARIANTOBJECT *pVarObj = GetOleVariantObject(aTHX_ self);
if (!pVarObj)
XSRETURN_EMPTY;
HRESULT hr;
VARIANT variant;
HV *olestash = GetWin32OleStash(aTHX_ self);
LCID lcid = (LCID)QueryPkgVar(aTHX_ olestash, LCID_NAME, LCID_LEN, lcidDefault);
SV *sv = &PL_sv_undef;
SetLastOleError(aTHX_ olestash);
VariantInit(&variant);
hr = VariantChangeTypeEx(&variant, &pVarObj->variant, lcid, 0, (VARTYPE)type);
if (SUCCEEDED(hr)) {
sv = sv_newmortal();
hr = SetSVFromVariantEx(aTHX_ &variant, sv, olestash);
}
else if (V_VT(&pVarObj->variant) == VT_ERROR) {
/* special handling for VT_ERROR */
sv = sv_newmortal();
V_VT(&variant) = VT_I4;
V_I4(&variant) = V_ERROR(&pVarObj->variant);
hr = SetSVFromVariantEx(aTHX_ &variant, sv, olestash, FALSE);
}
VariantClear(&variant);
CheckOleError(aTHX_ olestash, hr);
ST(0) = sv;
XSRETURN(1);
}
void
ChangeType(self,type)
SV *self
IV type
PPCODE:
{
WINOLEVARIANTOBJECT *pVarObj = GetOleVariantObject(aTHX_ self);
if (!pVarObj)
XSRETURN_EMPTY;
HRESULT hr = E_INVALIDARG;
HV *olestash = GetWin32OleStash(aTHX_ self);
LCID lcid = (LCID)QueryPkgVar(aTHX_ olestash, LCID_NAME, LCID_LEN, lcidDefault);
SetLastOleError(aTHX_ olestash);
/* XXX: Does it work with VT_BYREF? */
hr = VariantChangeTypeEx(&pVarObj->variant, &pVarObj->variant,
lcid, 0, (VARTYPE)type);
CheckOleError(aTHX_ olestash, hr);
ST(0) = SUCCEEDED(hr) ? self : &PL_sv_undef;
XSRETURN(1);
}
void
Copy(self,...)
SV *self
ALIAS:
_Clone = 1
PPCODE:
{
WINOLEVARIANTOBJECT *pVarObj = GetOleVariantObject(aTHX_ self);
if (!pVarObj)
XSRETURN_EMPTY;
HRESULT hr;
HV *olestash = GetWin32OleStash(aTHX_ self);
VARIANT *pSource = &pVarObj->variant;
VARIANT variant, byref;
VariantInit(&variant);
VariantInit(&byref);
/* Copy(DIM) makes a copy of a SAFEARRAY element */
if (items > 1) {
if (ix != 0) {
warn(MY_VERSION ": Win32::OLE::Variant->_Clone doesn't support "
"array elements");
XSRETURN_EMPTY;
}
if (!V_ISARRAY(&pVarObj->variant)) {
warn(MY_VERSION ": Win32::OLE::Variant->Copy(): %d %s specified, "
"but variant is not a SAFEARRYA", items-1,
items > 2 ? "indices" : "index");
XSRETURN_EMPTY;
}
SAFEARRAY *psa = V_ISBYREF(pSource) ? *V_ARRAYREF(pSource)
: V_ARRAY(pSource);
int cDims = SafeArrayGetDim(psa);
if (items-1 != cDims) {
warn(MY_VERSION ": Win32::OLE::Variant->Copy() indices mismatch: "
"specified %d vs. required %d", items-1, cDims);
XSRETURN_EMPTY;
}
LONG *rgIndices;
New(0, rgIndices, cDims, LONG);
for (int iDim=0; iDim < cDims; ++iDim)
rgIndices[iDim] = (long)SvIV(ST(1+iDim));
VARTYPE vt_base = V_VT(pSource) & VT_TYPEMASK;
V_VT(&variant) = vt_base | VT_BYREF;
V_VT(&byref) = vt_base;
if (vt_base == VT_VARIANT)
V_VARIANTREF(&variant) = &byref;
else
V_BYREF(&variant) = &V_BYREF(&byref);
hr = SafeArrayGetElement(psa, rgIndices, V_BYREF(&variant));
Safefree(rgIndices);
if (CheckOleError(aTHX_ olestash, hr))
XSRETURN_EMPTY;
pSource = &variant;
}
WINOLEVARIANTOBJECT *pNewVar;
Newz(0, pNewVar, 1, WINOLEVARIANTOBJECT);
VariantInit(&pNewVar->variant);
VariantInit(&pNewVar->byref);
if (ix == 0)
hr = VariantCopyInd(&pNewVar->variant, pSource);
else
hr = MyVariantCopy(&pNewVar->variant, pSource);
VariantClear(&byref);
if (FAILED(hr)) {
Safefree(pNewVar);
ReportOleError(aTHX_ olestash, hr);
XSRETURN_EMPTY;
}
AddToObjectChain(aTHX_ (OBJECTHEADER*)pNewVar, WINOLEVARIANT_MAGIC);
HV *stash = GetStash(aTHX_ self);
SV *sv = newSViv(PTR2IV(pNewVar));
ST(0) = sv_2mortal(sv_bless(newRV_noinc(sv), stash));
XSRETURN(1);
}
void
Date(self,...)
SV *self
ALIAS:
Time = 1
PPCODE:
{
WINOLEVARIANTOBJECT *pVarObj = GetOleVariantObject(aTHX_ self);
if (!pVarObj)
XSRETURN_EMPTY;
if (items > 3) {
char *method[] = {"Date", "Time"};
warn("Usage: Win32::OLE::Variant::%s"
"(SELF [, FORMAT [, LCID]])", method[ix]);
XSRETURN_EMPTY;
}
HV *olestash = GetWin32OleStash(aTHX_ self);
SetLastOleError(aTHX_ olestash);
char *fmt = NULL;
DWORD dwFlags = 0;
LCID lcid = lcidDefault;
if (items > 1) {
if (SvIOK(ST(1)))
dwFlags = (DWORD)SvIV(ST(1));
else if SvPOK(ST(1))
fmt = SvPV_nolen(ST(1));
}
if (items > 2)
lcid = (LCID)SvIV(ST(2));
else
lcid = (LCID)QueryPkgVar(aTHX_ olestash, LCID_NAME, LCID_LEN, lcidDefault);
HRESULT hr;
VARIANT variant;
VariantInit(&variant);
hr = VariantChangeTypeEx(&variant, &pVarObj->variant, lcid, 0, VT_DATE);
if (CheckOleError(aTHX_ olestash, hr))
XSRETURN_EMPTY;
SYSTEMTIME systime;
VariantTimeToSystemTime(V_DATE(&variant), &systime);
int len;
if (ix == 0)
len = GetDateFormatA(lcid, dwFlags, &systime, fmt, NULL, 0);
else
len = GetTimeFormatA(lcid, dwFlags, &systime, fmt, NULL, 0);
if (len > 1) {
SV *sv = ST(0) = sv_2mortal(newSV(len));
if (ix == 0)
len = GetDateFormatA(lcid, dwFlags, &systime, fmt, SvPVX(sv), len);
else
len = GetTimeFormatA(lcid, dwFlags, &systime, fmt, SvPVX(sv), len);
if (len > 1) {
SvCUR_set(sv, len-1);
SvPOK_on(sv);
}
}
else
ST(0) = &PL_sv_undef;
VariantClear(&variant);
XSRETURN(1);
}
void
Currency(self,...)
SV *self
PPCODE:
{
WINOLEVARIANTOBJECT *pVarObj = GetOleVariantObject(aTHX_ self);
if (!pVarObj)
XSRETURN_EMPTY;
if (items > 3) {
warn("Usage: Win32::OLE::Variant::Currency"
"(SELF [, CURRENCYFMT [, LCID]])");
XSRETURN_EMPTY;
}
HV *olestash = GetWin32OleStash(aTHX_ self);
SetLastOleError(aTHX_ olestash);
HV *hv = NULL;
DWORD dwFlags = 0;
LCID lcid = lcidDefault;
if (items > 1) {
SV *format = ST(1);
if (SvIOK(format))
dwFlags = (DWORD)SvIV(format);
else if (SvROK(format) && SvTYPE(SvRV(format)) == SVt_PVHV)
hv = (HV*)SvRV(format);
else {
croak("Win32::OLE::Variant::GetCurrencyFormat: "
"CURRENCYFMT must be a HASH reference");
XSRETURN_EMPTY;
}
}
if (items > 2)
lcid = (LCID)SvIV(ST(2));
else
lcid = (LCID)QueryPkgVar(aTHX_ olestash, LCID_NAME, LCID_LEN, lcidDefault);
HRESULT hr;
VARIANT variant;
VariantInit(&variant);
hr = VariantChangeTypeEx(&variant, &pVarObj->variant, lcid, 0, VT_CY);
if (CheckOleError(aTHX_ olestash, hr))
XSRETURN_EMPTY;
CURRENCYFMTA afmt;
Zero(&afmt, 1, CURRENCYFMTA);
afmt.NumDigits = (UINT)GetLocaleNumber(aTHX_ hv, "NumDigits",
lcid, LOCALE_IDIGITS);
afmt.LeadingZero = (UINT)GetLocaleNumber(aTHX_ hv, "LeadingZero",
lcid, LOCALE_ILZERO);
afmt.Grouping = (UINT)GetLocaleNumber(aTHX_ hv, "Grouping",
lcid, LOCALE_SMONGROUPING);
afmt.NegativeOrder = (UINT)GetLocaleNumber(aTHX_ hv, "NegativeOrder",
lcid, LOCALE_INEGCURR);
afmt.PositiveOrder = (UINT)GetLocaleNumber(aTHX_ hv, "PositiveOrder",
lcid, LOCALE_ICURRENCY);
afmt.lpDecimalSep = GetLocaleString(aTHX_ hv, "DecimalSep",
lcid, LOCALE_SMONDECIMALSEP);
afmt.lpThousandSep = GetLocaleString(aTHX_ hv, "ThousandSep",
lcid, LOCALE_SMONTHOUSANDSEP);
afmt.lpCurrencySymbol = GetLocaleString(aTHX_ hv, "CurrencySymbol",
lcid, LOCALE_SCURRENCY);
int len = 0;
int sign = 0;
char amount[40];
unsigned __int64 u64 = *(unsigned __int64*)&V_CY(&variant);
if ((__int64)u64 < 0) {
amount[len++] = '-';
u64 = (unsigned __int64)(-(__int64)u64);
sign = 1;
}
while (u64) {
amount[len++] = (char)(u64%10 + '0');
u64 /= 10;
}
if (len == sign)
amount[len++] = '0';
amount[len] = '\0';
strrev(amount+sign);
/* VT_CY has an implied decimal point before the last 4 digits */
SV *number;
if (len-sign < 5)
number = newSVpvf("%.*s0.%.*s%s", sign, amount,
4-(len-sign), "000", amount+sign);
else
number = newSVpvf("%.*s.%s", len-4, amount, amount+len-4);
DBG(("amount='%s' number='%s' len=%d sign=%d", amount, SvPVX(number),
len, sign));
char* pNumber = SvPVX(number);
len = GetCurrencyFormatA(lcid, dwFlags, pNumber, &afmt, NULL, 0);
if (len > 1) {
SV *sv = ST(0) = sv_2mortal(newSV(len));
len = GetCurrencyFormatA(lcid, dwFlags, pNumber, &afmt,
SvPVX(sv), len);
if (len > 1) {
SvCUR_set(sv, len-1);
SvPOK_on(sv);
}
}
else
ST(0) = &PL_sv_undef;
SvREFCNT_dec(number);
VariantClear(&variant);
XSRETURN(1);
}
void
Number(self,...)
SV *self
PPCODE:
{
WINOLEVARIANTOBJECT *pVarObj = GetOleVariantObject(aTHX_ self);
if (!pVarObj)
XSRETURN_EMPTY;
if (items > 3) {
warn("Usage: Win32::OLE::Variant::Number"
"(SELF [, NUMBERFMT [, LCID]])");
XSRETURN_EMPTY;
}
HV *olestash = GetWin32OleStash(aTHX_ self);
SetLastOleError(aTHX_ olestash);
HV *hv = NULL;
DWORD dwFlags = 0;
LCID lcid = lcidDefault;
if (items > 1) {
SV *format = ST(1);
if (SvIOK(format))
dwFlags = (DWORD)SvIV(format);
else if (SvROK(format) && SvTYPE(SvRV(format)) == SVt_PVHV)
hv = (HV*)SvRV(format);
else {
croak("Win32::OLE::Variant::GetNumberFormat: "
"NUMBERFMT must be a HASH reference");
XSRETURN_EMPTY;
}
}
if (items > 2)
lcid = (LCID)SvIV(ST(2));
else
lcid = (LCID)QueryPkgVar(aTHX_ olestash, LCID_NAME, LCID_LEN, lcidDefault);
HRESULT hr;
VARIANT variant;
VariantInit(&variant);
hr = VariantChangeTypeEx(&variant, &pVarObj->variant, lcid, 0, VT_R8);
if (CheckOleError(aTHX_ olestash, hr))
XSRETURN_EMPTY;
UINT NumDigits;
NUMBERFMTA afmt;
Zero(&afmt, 1, NUMBERFMT);
afmt.NumDigits = (UINT)GetLocaleNumber(aTHX_ hv, "NumDigits",
lcid, LOCALE_IDIGITS);
afmt.LeadingZero = (UINT)GetLocaleNumber(aTHX_ hv, "LeadingZero",
lcid, LOCALE_ILZERO);
afmt.Grouping = (UINT)GetLocaleNumber(aTHX_ hv, "Grouping",
lcid, LOCALE_SGROUPING);
afmt.NegativeOrder = (UINT)GetLocaleNumber(aTHX_ hv, "NegativeOrder",
lcid, LOCALE_INEGNUMBER);
afmt.lpDecimalSep = GetLocaleString(aTHX_ hv, "DecimalSep",
lcid, LOCALE_SDECIMAL);
afmt.lpThousandSep = GetLocaleString(aTHX_ hv, "ThousandSep",
lcid, LOCALE_STHOUSAND);
NumDigits = afmt.NumDigits;
int len;
SV *number = newSVpvf("%.*f", NumDigits, V_R8(&variant));
char* pNumber = SvPVX(number);
len = GetNumberFormatA(lcid, dwFlags, pNumber, &afmt, NULL, 0);
if (len > 1) {
SV *sv = ST(0) = sv_2mortal(newSV(len));
len = GetNumberFormatA(lcid, dwFlags, pNumber, &afmt,
SvPVX(sv), len);
if (len > 1) {
SvCUR_set(sv, len-1);
SvPOK_on(sv);
}
}
else
ST(0) = &PL_sv_undef;
SvREFCNT_dec(number);
VariantClear(&variant);
XSRETURN(1);
}
void
Dim(self)
SV *self
PPCODE:
{
WINOLEVARIANTOBJECT *pVarObj = GetOleVariantObject(aTHX_ self);
if (!pVarObj)
XSRETURN_EMPTY;
VARIANT *pVariant = &pVarObj->variant;
while (V_VT(pVariant) == (VT_VARIANT | VT_BYREF))
pVariant = V_VARIANTREF(pVariant);
if (!V_ISARRAY(pVariant)) {
warn(MY_VERSION ": Win32::OLE::Variant->Dim(): Variant type (0x%x) "
"is not an array", V_VT(pVariant));
XSRETURN_EMPTY;
}
SAFEARRAY *psa;
if (V_ISBYREF(pVariant))
psa = *V_ARRAYREF(pVariant);
else
psa = V_ARRAY(pVariant);
HRESULT hr = S_OK;
int cDims = SafeArrayGetDim(psa);
for (int iDim=0; iDim < cDims; ++iDim) {
LONG lLBound, lUBound;
hr = SafeArrayGetLBound(psa, 1+iDim, &lLBound);
if (FAILED(hr))
break;
hr = SafeArrayGetUBound(psa, 1+iDim, &lUBound);
if (FAILED(hr))
break;
AV *av = newAV();
av_push(av, newSViv(lLBound));
av_push(av, newSViv(lUBound));
XPUSHs(sv_2mortal(newRV_noinc((SV*)av)));
}
HV *olestash = GetWin32OleStash(aTHX_ self);
if (CheckOleError(aTHX_ olestash, hr))
XSRETURN_EMPTY;
/* return list of array refs on stack */
}
void
Get(self,...)
SV *self
ALIAS:
Put = 1
PPCODE:
{
char *paszMethod[] = {"Get", "Put"};
WINOLEVARIANTOBJECT *pVarObj = GetOleVariantObject(aTHX_ self);
if (!pVarObj)
XSRETURN_EMPTY;
HV *olestash = GetWin32OleStash(aTHX_ self);
VARIANT *pVariant = &pVarObj->variant;
while (V_VT(pVariant) == (VT_VARIANT | VT_BYREF))
pVariant = V_VARIANTREF(pVariant);
if (!V_ISARRAY(pVariant)) {
if (items-1 != ix) {
warn(MY_VERSION ": Win32::OLE::Variant->%s(): Wrong number of "
"arguments" , paszMethod[ix]);
XSRETURN_EMPTY;
}
scalar_mode:
HRESULT hr;
SV *sv;
if (ix == 0) { /* Get */
sv = sv_newmortal();
hr = SetSVFromVariantEx(aTHX_ pVariant, sv, olestash);
}
else { /* Put */
UINT cp = (UINT)QueryPkgVar(aTHX_ olestash, CP_NAME, CP_LEN, cpDefault);
LCID lcid = (LCID)QueryPkgVar(aTHX_ olestash, LCID_NAME, LCID_LEN,
lcidDefault);
sv = self;
hr = AssignVariantFromSV(aTHX_ ST(1), pVariant, cp, lcid);
}
CheckOleError(aTHX_ olestash, hr);
ST(0) = sv;
XSRETURN(1);
}
SAFEARRAY *psa = V_ISBYREF(pVariant) ? *V_ARRAYREF(pVariant)
: V_ARRAY(pVariant);
int cDims = SafeArrayGetDim(psa);
/* Special case for one-dimensional VT_UI1 arrays */
VARTYPE vt_base = V_VT(pVariant) & VT_TYPEMASK;
if (vt_base == VT_UI1 && cDims == 1 && items-1 == ix)
goto scalar_mode;
/* Array Put, e.g. $array->Put([ [11,12], [21,22] ]) */
if (ix == 1 && items == 2 && SvROK(ST(1)) &&
SvTYPE(SvRV(ST(1))) == SVt_PVAV)
{
UINT cp = (UINT)QueryPkgVar(aTHX_ olestash, CP_NAME, CP_LEN, cpDefault);
LCID lcid = (LCID)QueryPkgVar(aTHX_ olestash, LCID_NAME, LCID_LEN,
lcidDefault);
HRESULT hr = SetSafeArrayFromAV(aTHX_ (AV*)SvRV(ST(1)), vt_base, psa,
cDims, cp, lcid);
CheckOleError(aTHX_ olestash, hr);
ST(0) = self;
XSRETURN(1);
}
if (items-1 != cDims+ix) {
warn(MY_VERSION ": Win32::OLE::Variant->%s(): Wrong number of indices; "
" dimension of SafeArray is %d", paszMethod[ix], cDims);
XSRETURN_EMPTY;
}
LONG *rgIndices;
New(0, rgIndices, cDims, LONG);
for (int iDim=0; iDim < cDims; ++iDim)
rgIndices[iDim] = (long)SvIV(ST(1+iDim));
VARIANT variant, byref;
VariantInit(&variant);
VariantInit(&byref);
V_VT(&variant) = vt_base | VT_BYREF;
V_VT(&byref) = vt_base;
if (vt_base == VT_VARIANT)
V_VARIANTREF(&variant) = &byref;
else {
V_BYREF(&variant) = &V_BYREF(&byref);
if (vt_base == VT_BSTR)
V_BSTR(&byref) = NULL;
else if (vt_base == VT_DISPATCH)
V_DISPATCH(&byref) = NULL;
else if (vt_base == VT_UNKNOWN)
V_UNKNOWN(&byref) = NULL;
}
HRESULT hr = S_OK;
SV *sv = &PL_sv_undef;
if (ix == 0) { /* Get */
hr = SafeArrayGetElement(psa, rgIndices, V_BYREF(&variant));
if (SUCCEEDED(hr)) {
sv = sv_newmortal();
hr = SetSVFromVariantEx(aTHX_ &variant, sv, olestash);
}
}
else { /* Put */
UINT cp = (UINT)QueryPkgVar(aTHX_ olestash, CP_NAME, CP_LEN, cpDefault);
LCID lcid = (LCID)QueryPkgVar(aTHX_ olestash, LCID_NAME, LCID_LEN,
lcidDefault);
hr = AssignVariantFromSV(aTHX_ ST(items-1), &variant, cp, lcid);
if (SUCCEEDED(hr)) {
if (vt_base == VT_BSTR)
hr = SafeArrayPutElement(psa, rgIndices, V_BSTR(&byref));
else if (vt_base == VT_DISPATCH)
hr = SafeArrayPutElement(psa, rgIndices, V_DISPATCH(&byref));
else if (vt_base == VT_UNKNOWN)
hr = SafeArrayPutElement(psa, rgIndices, V_UNKNOWN(&byref));
else
hr = SafeArrayPutElement(psa, rgIndices, V_BYREF(&variant));
}
if (SUCCEEDED(hr))
sv = self;
}
VariantClear(&byref);
Safefree(rgIndices);
CheckOleError(aTHX_ olestash, hr);
ST(0) = sv;
XSRETURN(1);
}
void
LastError(self,...)
SV *self
PPCODE:
{
// Win32::OLE::Variant->LastError() exists only for backward compatibility.
// It is now just a proxy for Win32::OLE->LastError().
HV *olestash = GetWin32OleStash(aTHX_ self);
SV *sv = items == 1 ? NULL : ST(1);
PUSHMARK(sp);
PUSHs(sv_2mortal(newSVpv(HvNAME(olestash), 0)));
if (sv)
PUSHs(sv);
PUTBACK;
perl_call_method("LastError", GIMME_V);
SPAGAIN;
// return whatever Win32::OLE->LastError() returned
}
void
Type(self)
SV *self
ALIAS:
Value = 1
_Value = 2
_RefType = 3
IsNullString = 4
IsNothing = 5
PPCODE:
{
WINOLEVARIANTOBJECT *pVarObj = GetOleVariantObject(aTHX_ self);
SV *sv = &PL_sv_undef;
if (pVarObj) {
VARIANT *pVariant = &pVarObj->variant;
HRESULT hr;
HV *olestash = GetWin32OleStash(aTHX_ self);
SetLastOleError(aTHX_ olestash);
sv = sv_newmortal();
if (ix == 0) /* Type */
sv_setiv(sv, V_VT(pVariant));
else if (ix == 1) /* Value */
hr = SetSVFromVariantEx(aTHX_ pVariant, sv, olestash);
else if (ix == 2) /* _Value, see also: _Clone (alias of Copy) */
hr = SetSVFromVariantEx(aTHX_ pVariant, sv, olestash,
TRUE);
else if (ix == 3) { /* _RefType */
while (V_VT(pVariant) == (VT_BYREF|VT_VARIANT))
pVariant = V_VARIANTREF(pVariant);
sv_setiv(sv, V_VT(pVariant));
}
else if (ix == 4) { /* IsNullString */
if (V_VT(pVariant) == VT_BSTR && V_BSTR(pVariant) == NULL)
sv = &PL_sv_yes;
else
sv = &PL_sv_no;
}
else if (ix == 5) { /* IsNothing */
if (V_VT(pVariant) == VT_DISPATCH && V_DISPATCH(pVariant) == NULL)
sv = &PL_sv_yes;
else
sv = &PL_sv_no;
}
CheckOleError(aTHX_ olestash, hr);
}
ST(0) = sv;
XSRETURN(1);
}
void
Unicode(self)
SV *self
PPCODE:
{
WINOLEVARIANTOBJECT *pVarObj = GetOleVariantObject(aTHX_ self);
ST(0) = &PL_sv_undef;
if (pVarObj) {
VARIANT Variant;
VARIANT *pVariant = &pVarObj->variant;
HRESULT hr = S_OK;
HV *olestash = GetWin32OleStash(aTHX_ self);
SetLastOleError(aTHX_ olestash);
VariantInit(&Variant);
if ((V_VT(pVariant) & ~VT_BYREF) != VT_BSTR) {
LCID lcid = (LCID)QueryPkgVar(aTHX_ olestash,
LCID_NAME, LCID_LEN, lcidDefault);
hr = VariantChangeTypeEx(&Variant, pVariant, lcid, 0, VT_BSTR);
pVariant = &Variant;
}
if (!CheckOleError(aTHX_ olestash, hr)) {
BSTR bstr = V_ISBYREF(pVariant) ? *V_BSTRREF(pVariant)
: V_BSTR(pVariant);
STRLEN olecharlen = SysStringLen(bstr);
SV *sv = newSVpv((char*)bstr, 2*olecharlen);
U16 *pus = (U16*)SvPVX(sv);
for (STRLEN i=0; i < olecharlen; ++i)
pus[i] = htons(pus[i]);
ST(0) = sv_2mortal(sv_bless(newRV_noinc(sv),
gv_stashpv(szUNICODESTRING, TRUE)));
}
VariantClear(&Variant);
}
XSRETURN(1);
}
##############################################################################
MODULE = Win32::OLE PACKAGE = Win32::OLE::NLS
void
CompareString(lcid,flags,str1,str2)
IV lcid
IV flags
SV *str1
SV *str2
PPCODE:
{
STRLEN length1;
STRLEN length2;
char *string1 = SvPV(str1, length1);
char *string2 = SvPV(str2, length2);
IV res = CompareStringA((LCID)lcid, (DWORD)flags,
string1, (int)length1, string2, (int)length2);
XSRETURN_IV(res);
}
void
LCMapString(lcid,flags,str)
IV lcid
IV flags
SV *str
PPCODE:
{
SV *sv;
STRLEN length;
char *string = SvPV(str, length);
int len = LCMapStringA((LCID)lcid, (DWORD)flags, string, (int)length, NULL, 0);
if (len > 0) {
sv = sv_newmortal();
SvUPGRADE(sv, SVt_PV);
SvGROW(sv, (STRLEN)(len+1));
SvCUR_set(sv, LCMapStringA((LCID)lcid, (DWORD)flags, string, (int)length,
SvPVX(sv), (int)SvLEN(sv)));
if (SvCUR(sv))
SvPOK_on(sv);
}
else
sv = sv_newmortal();
ST(0) = sv;
XSRETURN(1);
}
void
GetLocaleInfo(lcid,lctype)
IV lcid
IV lctype
PPCODE:
{
SV *sv = sv_newmortal();
int len = GetLocaleInfoA((LCID)lcid, (LCTYPE)lctype, NULL, 0);
if (len > 0) {
SvUPGRADE(sv, SVt_PV);
SvGROW(sv, (STRLEN)len);
len = GetLocaleInfoA((LCID)lcid, (LCTYPE)lctype, SvPVX(sv), (int)SvLEN(sv));
if (len) {
SvCUR_set(sv, len-1);
SvPOK_on(sv);
}
}
ST(0) = sv;
XSRETURN(1);
}
void
GetStringType(lcid,type,str)
IV lcid
IV type
SV *str
PPCODE:
{
STRLEN len;
char *string = SvPV(str, len);
unsigned short *pCharType;
New(0, pCharType, len, unsigned short);
if (GetStringTypeA((LCID)lcid, (DWORD)type, string, (int)len, pCharType)) {
EXTEND(SP, (IV)len);
for (int i=0; i < (IV)len; ++i)
PUSHs(sv_2mortal(newSViv(pCharType[i])));
}
Safefree(pCharType);
}
void
GetSystemDefaultLangID()
PPCODE:
{
LANGID langID = GetSystemDefaultLangID();
if (langID != 0) {
EXTEND(SP, 1);
XSRETURN_IV(langID);
}
}
void
GetSystemDefaultLCID()
PPCODE:
{
LCID lcid = GetSystemDefaultLCID();
if (lcid != 0) {
EXTEND(SP, 1);
XSRETURN_IV(lcid);
}
}
void
GetUserDefaultLangID()
PPCODE:
{
LANGID langID = GetUserDefaultLangID();
if (langID != 0) {
EXTEND(SP, 1);
XSRETURN_IV(langID);
}
}
void
GetUserDefaultLCID()
PPCODE:
{
LCID lcid = GetUserDefaultLCID();
if (lcid != 0) {
EXTEND(SP, 1);
XSRETURN_IV(lcid);
}
}
void
SendSettingChange()
PPCODE:
{
DWORD_PTR dwResult;
SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, 0, 0,
SMTO_NORMAL, 5000, &dwResult);
XSRETURN_EMPTY;
}
void
SetLocaleInfo(lcid,lctype,lcdata)
IV lcid
IV lctype
char *lcdata
PPCODE:
{
BOOL result = SetLocaleInfoA((LCID)lcid, (LCTYPE)lctype, lcdata);
if (result)
XSRETURN_YES;
XSRETURN_EMPTY;
}
##############################################################################
MODULE = Win32::OLE PACKAGE = Win32::OLE::TypeLib
void
new(self,object)
SV *self
SV *object
PPCODE:
{
HRESULT hr;
HV *stash = Nullhv;
ITypeLib *pTypeLib;
TLIBATTR *pTLibAttr;
if (sv_isobject(object) && sv_derived_from(object, szWINOLE)) {
WINOLEOBJECT *pOleObj = GetOleObject(aTHX_ object);
if (!pOleObj)
XSRETURN_EMPTY;
unsigned int count;
hr = pOleObj->pDispatch->GetTypeInfoCount(&count);
stash = SvSTASH(pOleObj->self);
if (CheckOleError(aTHX_ stash, hr) || count == 0)
XSRETURN_EMPTY;
ITypeInfo *pTypeInfo;
hr = pOleObj->pDispatch->GetTypeInfo(0, lcidDefault, &pTypeInfo);
if (CheckOleError(aTHX_ stash, hr))
XSRETURN_EMPTY;
unsigned int index;
hr = pTypeInfo->GetContainingTypeLib(&pTypeLib, &index);
pTypeInfo->Release();
if (CheckOleError(aTHX_ stash, hr))
XSRETURN_EMPTY;
}
else {
stash = GetWin32OleStash(aTHX_ self);
UINT cp = (UINT)QueryPkgVar(aTHX_ stash, CP_NAME, CP_LEN, cpDefault);
OLECHAR Buffer[OLE_BUF_SIZ];
OLECHAR *pBuffer = GetWideChar(aTHX_ object, Buffer, OLE_BUF_SIZ, cp);
hr = LoadTypeLibEx(pBuffer, REGKIND_NONE, &pTypeLib);
ReleaseBuffer(aTHX_ pBuffer, Buffer);
if (CheckOleError(aTHX_ stash, hr))
XSRETURN_EMPTY;
}
hr = pTypeLib->GetLibAttr(&pTLibAttr);
if (FAILED(hr)) {
pTypeLib->Release();
ReportOleError(aTHX_ stash, hr);
XSRETURN_EMPTY;
}
ST(0) = sv_2mortal(CreateTypeLibObject(aTHX_ pTypeLib, pTLibAttr));
XSRETURN(1);
}
void
DESTROY(self)
SV *self
PPCODE:
{
WINOLETYPELIBOBJECT *pObj = GetOleTypeLibObject(aTHX_ self);
if (pObj) {
RemoveFromObjectChain(aTHX_ (OBJECTHEADER*)pObj);
if (pObj->pTypeLib) {
pObj->pTypeLib->ReleaseTLibAttr(pObj->pTLibAttr);
pObj->pTypeLib->Release();
}
Safefree(pObj);
}
XSRETURN_EMPTY;
}
void
_GetDocumentation(self,index=-1)
SV *self
IV index
PPCODE:
{
WINOLETYPELIBOBJECT *pObj = GetOleTypeLibObject(aTHX_ self);
if (!pObj)
XSRETURN_EMPTY;
DWORD dwHelpContext;
BSTR bstrName, bstrDocString, bstrHelpFile;
HRESULT hr = pObj->pTypeLib->GetDocumentation((INT)index, &bstrName,
&bstrDocString, &dwHelpContext, &bstrHelpFile);
HV *olestash = GetWin32OleStash(aTHX_ self);
if (CheckOleError(aTHX_ olestash, hr))
XSRETURN_EMPTY;
HV *hv = GetDocumentation(aTHX_ bstrName, bstrDocString,
dwHelpContext, bstrHelpFile);
ST(0) = sv_2mortal(newRV_noinc((SV*)hv));
XSRETURN(1);
}
void
_GetLibAttr(self)
SV *self
PPCODE:
{
WINOLETYPELIBOBJECT *pObj = GetOleTypeLibObject(aTHX_ self);
if (!pObj)
XSRETURN_EMPTY;
TLIBATTR *p = pObj->pTLibAttr;
HV *hv = newHV();
hv_store(hv, "lcid", 4, newSViv(p->lcid), 0);
hv_store(hv, "syskind", 7, newSViv(p->syskind), 0);
hv_store(hv, "wLibFlags", 9, newSViv(p->wLibFlags), 0);
hv_store(hv, "wMajorVerNum", 12, newSViv(p->wMajorVerNum), 0);
hv_store(hv, "wMinorVerNum", 12, newSViv(p->wMinorVerNum), 0);
hv_store(hv, "guid", 4, SetSVFromGUID(aTHX_ p->guid), 0);
ST(0) = sv_2mortal(newRV_noinc((SV*)hv));
XSRETURN(1);
}
void
_GetTypeInfoCount(self)
SV *self
PPCODE:
{
WINOLETYPELIBOBJECT *pObj = GetOleTypeLibObject(aTHX_ self);
if (!pObj)
XSRETURN_EMPTY;
XSRETURN_IV(pObj->pTypeLib->GetTypeInfoCount());
}
void
_GetTypeInfo(self,index)
SV *self
IV index
PPCODE:
{
WINOLETYPELIBOBJECT *pObj = GetOleTypeLibObject(aTHX_ self);
if (!pObj)
XSRETURN_EMPTY;
ITypeInfo *pTypeInfo;
TYPEATTR *pTypeAttr;
HV *olestash = GetWin32OleStash(aTHX_ self);
HRESULT hr = pObj->pTypeLib->GetTypeInfo((UINT)index, &pTypeInfo);
if (CheckOleError(aTHX_ olestash, hr))
XSRETURN_EMPTY;
hr = pTypeInfo->GetTypeAttr(&pTypeAttr);
if (FAILED(hr)) {
pTypeInfo->Release();
ReportOleError(aTHX_ olestash, hr);
XSRETURN_EMPTY;
}
ST(0) = sv_2mortal(CreateTypeInfoObject(aTHX_ pTypeInfo, pTypeAttr));
XSRETURN(1);
}
void
GetTypeInfo(self,name,...)
SV *self
SV *name
PPCODE:
{
WINOLETYPELIBOBJECT *pObj = GetOleTypeLibObject(aTHX_ self);
if (!pObj)
XSRETURN_EMPTY;
ITypeInfo *pTypeInfo;
TYPEATTR *pTypeAttr;
HV *olestash = GetWin32OleStash(aTHX_ self);
if (SvIOK(name)) {
HRESULT hr = pObj->pTypeLib->GetTypeInfo((UINT)SvIV(name), &pTypeInfo);
if (CheckOleError(aTHX_ olestash, hr))
XSRETURN_EMPTY;
hr = pTypeInfo->GetTypeAttr(&pTypeAttr);
if (FAILED(hr)) {
pTypeInfo->Release();
ReportOleError(aTHX_ olestash, hr);
XSRETURN_EMPTY;
}
ST(0) = sv_2mortal(CreateTypeInfoObject(aTHX_ pTypeInfo, pTypeAttr));
XSRETURN(1);
}
UINT cp = (UINT)QueryPkgVar(aTHX_ olestash, CP_NAME, CP_LEN, cpDefault);
TYPEKIND tkind = items > 2 ? (TYPEKIND)SvIV(ST(2)) : TKIND_MAX;
char *pszName = SvPV_nolen(name);
int count = pObj->pTypeLib->GetTypeInfoCount();
for (int index = 0; index < count; ++index) {
HRESULT hr = pObj->pTypeLib->GetTypeInfo(index, &pTypeInfo);
if (CheckOleError(aTHX_ olestash, hr))
XSRETURN_EMPTY;
BSTR bstrName;
hr = pTypeInfo->GetDocumentation(-1, &bstrName, NULL, NULL, NULL);
char szStr[OLE_BUF_SIZ];
char *pszStr = GetMultiByte(aTHX_ bstrName, szStr, sizeof(szStr), cp);
int equal = strEQ(pszStr, pszName);
ReleaseBuffer(aTHX_ pszStr, szStr);
SysFreeString(bstrName);
if (!equal) {
pTypeInfo->Release();
continue;
}
hr = pTypeInfo->GetTypeAttr(&pTypeAttr);
if (FAILED(hr)) {
pTypeInfo->Release();
ReportOleError(aTHX_ olestash, hr);
XSRETURN_EMPTY;
}
if (tkind == TKIND_MAX || tkind == pTypeAttr->typekind) {
ST(0) = sv_2mortal(CreateTypeInfoObject(aTHX_ pTypeInfo, pTypeAttr));
XSRETURN(1);
}
pTypeInfo->ReleaseTypeAttr(pTypeAttr);
pTypeInfo->Release();
}
XSRETURN_EMPTY;
}
##############################################################################
MODULE = Win32::OLE PACKAGE = Win32::OLE::TypeInfo
void
_new(self,object)
SV *self
SV *object
PPCODE:
{
ITypeInfo *pTypeInfo;
TYPEATTR *pTypeAttr;
WINOLEOBJECT *pOleObj = GetOleObject(aTHX_ object);
if (!pOleObj)
XSRETURN_EMPTY;
unsigned int count;
HRESULT hr = pOleObj->pDispatch->GetTypeInfoCount(&count);
HV *olestash = SvSTASH(pOleObj->self);
if (CheckOleError(aTHX_ olestash, hr) || count == 0)
XSRETURN_EMPTY;
hr = pOleObj->pDispatch->GetTypeInfo(0, lcidDefault, &pTypeInfo);
if (CheckOleError(aTHX_ olestash, hr))
XSRETURN_EMPTY;
hr = pTypeInfo->GetTypeAttr(&pTypeAttr);
if (FAILED(hr)) {
pTypeInfo->Release();
ReportOleError(aTHX_ olestash, hr);
XSRETURN_EMPTY;
}
ST(0) = sv_2mortal(CreateTypeInfoObject(aTHX_ pTypeInfo, pTypeAttr));
XSRETURN(1);
}
void
DESTROY(self)
SV *self
PPCODE:
{
WINOLETYPEINFOOBJECT *pObj = GetOleTypeInfoObject(aTHX_ self);
if (pObj) {
RemoveFromObjectChain(aTHX_ (OBJECTHEADER*)pObj);
if (pObj->pTypeInfo) {
pObj->pTypeInfo->ReleaseTypeAttr(pObj->pTypeAttr);
pObj->pTypeInfo->Release();
}
Safefree(pObj);
}
XSRETURN_EMPTY;
}
void
GetContainingTypeLib(self)
SV *self
PPCODE:
{
ITypeLib *pTypeLib;
TLIBATTR *pTLibAttr;
WINOLETYPEINFOOBJECT *pObj = GetOleTypeInfoObject(aTHX_ self);
if (!pObj)
XSRETURN_EMPTY;
unsigned int index;
HV *olestash = GetWin32OleStash(aTHX_ self);
HRESULT hr = pObj->pTypeInfo->GetContainingTypeLib(&pTypeLib, &index);
if (CheckOleError(aTHX_ olestash, hr))
XSRETURN_EMPTY;
hr = pTypeLib->GetLibAttr(&pTLibAttr);
if (FAILED(hr)) {
pTypeLib->Release();
ReportOleError(aTHX_ olestash, hr);
XSRETURN_EMPTY;
}
ST(0) = sv_2mortal(CreateTypeLibObject(aTHX_ pTypeLib, pTLibAttr));
XSRETURN(1);
}
void
_GetDocumentation(self,memid=-1)
SV *self
IV memid
PPCODE:
{
WINOLETYPEINFOOBJECT *pObj = GetOleTypeInfoObject(aTHX_ self);
if (!pObj)
XSRETURN_EMPTY;
DWORD dwHelpContext;
BSTR bstrName, bstrDocString, bstrHelpFile;
HV *olestash = GetWin32OleStash(aTHX_ self);
HRESULT hr = pObj->pTypeInfo->GetDocumentation((MEMBERID)memid, &bstrName,
&bstrDocString, &dwHelpContext, &bstrHelpFile);
if (CheckOleError(aTHX_ olestash, hr))
XSRETURN_EMPTY;
HV *hv = GetDocumentation(aTHX_ bstrName, bstrDocString,
dwHelpContext, bstrHelpFile);
ST(0) = sv_2mortal(newRV_noinc((SV*)hv));
XSRETURN(1);
}
void
_GetFuncDesc(self,index)
SV *self
IV index
PPCODE:
{
WINOLETYPEINFOOBJECT *pObj = GetOleTypeInfoObject(aTHX_ self);
if (!pObj)
XSRETURN_EMPTY;
FUNCDESC *p;
HV *olestash = GetWin32OleStash(aTHX_ self);
HRESULT hr = pObj->pTypeInfo->GetFuncDesc((UINT)index, &p);
if (CheckOleError(aTHX_ olestash, hr))
XSRETURN_EMPTY;
HV *hv = newHV();
hv_store(hv, "memid", 5, newSViv(p->memid), 0);
// /* [size_is] */ SCODE __RPC_FAR *lprgscode;
hv_store(hv, "funckind", 8, newSViv(p->funckind), 0);
hv_store(hv, "invkind", 7, newSViv(p->invkind), 0);
hv_store(hv, "callconv", 8, newSViv(p->callconv), 0);
hv_store(hv, "cParams", 7, newSViv(p->cParams), 0);
hv_store(hv, "cParamsOpt", 10, newSViv(p->cParamsOpt), 0);
hv_store(hv, "oVft", 4, newSViv(p->oVft), 0);
hv_store(hv, "cScodes", 7, newSViv(p->cScodes), 0);
hv_store(hv, "wFuncFlags", 10, newSViv(p->wFuncFlags), 0);
HV *elemdesc = TranslateElemDesc(aTHX_ &p->elemdescFunc, pObj, olestash);
hv_store(hv, "elemdescFunc", 12, newRV_noinc((SV*)elemdesc), 0);
if (p->cParams > 0) {
AV *av = newAV();
for (int i = 0; i < p->cParams; ++i) {
elemdesc = TranslateElemDesc(aTHX_ &p->lprgelemdescParam[i],
pObj, olestash);
av_push(av, newRV_noinc((SV*)elemdesc));
}
hv_store(hv, "rgelemdescParam", 15, newRV_noinc((SV*)av), 0);
}
pObj->pTypeInfo->ReleaseFuncDesc(p);
ST(0) = sv_2mortal(newRV_noinc((SV*)hv));
XSRETURN(1);
}
void
_GetImplTypeFlags(self,index)
SV *self
IV index
PPCODE:
{
WINOLETYPEINFOOBJECT *pObj = GetOleTypeInfoObject(aTHX_ self);
if (!pObj)
XSRETURN_EMPTY;
int flags;
HV *olestash = GetWin32OleStash(aTHX_ self);
HRESULT hr = pObj->pTypeInfo->GetImplTypeFlags((UINT)index, &flags);
if (CheckOleError(aTHX_ olestash, hr))
XSRETURN_EMPTY;
XSRETURN_IV(flags);
}
void
_GetImplTypeInfo(self,index)
SV *self
IV index
PPCODE:
{
HREFTYPE hRefType;
ITypeInfo *pTypeInfo;
TYPEATTR *pTypeAttr;
WINOLETYPEINFOOBJECT *pObj = GetOleTypeInfoObject(aTHX_ self);
if (!pObj)
XSRETURN_EMPTY;
HV *olestash = GetWin32OleStash(aTHX_ self);
HRESULT hr = pObj->pTypeInfo->GetRefTypeOfImplType((UINT)index, &hRefType);
if (CheckOleError(aTHX_ olestash, hr))
XSRETURN_EMPTY;
hr = pObj->pTypeInfo->GetRefTypeInfo(hRefType, &pTypeInfo);
if (CheckOleError(aTHX_ olestash, hr))
XSRETURN_EMPTY;
hr = pTypeInfo->GetTypeAttr(&pTypeAttr);
if (FAILED(hr)) {
pTypeInfo->Release();
ReportOleError(aTHX_ olestash, hr);
XSRETURN_EMPTY;
}
New(0, pObj, 1, WINOLETYPEINFOOBJECT);
pObj->pTypeInfo = pTypeInfo;
pObj->pTypeAttr = pTypeAttr;
AddToObjectChain(aTHX_ (OBJECTHEADER*)pObj, WINOLETYPEINFO_MAGIC);
SV *sv = newSViv(PTR2IV(pObj));
ST(0) = sv_2mortal(sv_bless(newRV_noinc(sv), GetStash(aTHX_ self)));
XSRETURN(1);
}
void
_GetNames(self,memid,count)
SV *self
IV memid
IV count
PPCODE:
{
WINOLETYPEINFOOBJECT *pObj = GetOleTypeInfoObject(aTHX_ self);
if (!pObj)
XSRETURN_EMPTY;
BSTR *rgbstr;
New(0, rgbstr, count, BSTR);
unsigned int cNames;
HV *olestash = GetWin32OleStash(aTHX_ self);
HRESULT hr = pObj->pTypeInfo->GetNames((MEMBERID)memid, rgbstr, (UINT)count, &cNames);
if (CheckOleError(aTHX_ olestash, hr))
XSRETURN_EMPTY;
AV *av = newAV();
for (int i = 0; i < (int)cNames; ++i) {
char szName[32];
// XXX use correct codepage ???
char *pszName = GetMultiByte(aTHX_ rgbstr[i],
szName, sizeof(szName), CP_ACP);
SysFreeString(rgbstr[i]);
av_push(av, newSVpv(pszName, 0));
ReleaseBuffer(aTHX_ pszName, szName);
}
Safefree(rgbstr);
ST(0) = sv_2mortal(newRV_noinc((SV*)av));
XSRETURN(1);
}
void
_GetTypeAttr(self)
SV *self
PPCODE:
{
WINOLETYPEINFOOBJECT *pObj = GetOleTypeInfoObject(aTHX_ self);
if (!pObj)
XSRETURN_EMPTY;
TYPEATTR *p = pObj->pTypeAttr;
HV *hv = newHV();
hv_store(hv, "guid", 4, SetSVFromGUID(aTHX_ p->guid), 0);
hv_store(hv, "lcid", 4, newSViv(p->lcid), 0);
hv_store(hv, "memidConstructor", 16, newSViv(p->memidConstructor), 0);
hv_store(hv, "memidDestructor", 15, newSViv(p->memidDestructor), 0);
hv_store(hv, "typekind", 8, newSViv(p->typekind), 0);
hv_store(hv, "cFuncs", 6, newSViv(p->cFuncs), 0);
hv_store(hv, "cVars", 5, newSViv(p->cVars), 0);
hv_store(hv, "cImplTypes", 10, newSViv(p->cImplTypes), 0);
hv_store(hv, "cbSizeVft", 9, newSViv(p->cbSizeVft), 0);
hv_store(hv, "wTypeFlags", 10, newSViv(p->wTypeFlags), 0);
hv_store(hv, "wMajorVerNum", 12, newSViv(p->wMajorVerNum), 0);
hv_store(hv, "wMinorVerNum", 12, newSViv(p->wMinorVerNum), 0);
//TYPEDESC tdescAlias; // If TypeKind == TKIND_ALIAS,
// // specifies the type for which
// // this type is an alias.
//IDLDESC idldescType; // IDL attributes of the
// // described type.
ST(0) = sv_2mortal(newRV_noinc((SV*)hv));
XSRETURN(1);
}
void
_GetVarDesc(self,index)
SV *self
IV index
PPCODE:
{
WINOLETYPEINFOOBJECT *pObj = GetOleTypeInfoObject(aTHX_ self);
if (!pObj)
XSRETURN_EMPTY;
VARDESC *p;
HV *olestash = GetWin32OleStash(aTHX_ self);
HRESULT hr = pObj->pTypeInfo->GetVarDesc((UINT)index, &p);
if (CheckOleError(aTHX_ olestash, hr))
XSRETURN_EMPTY;
HV *hv = newHV();
hv_store(hv, "memid", 5, newSViv(p->memid), 0);
// LPOLESTR lpstrSchema;
hv_store(hv, "wVarFlags", 9, newSViv(p->wVarFlags), 0);
hv_store(hv, "varkind", 7, newSViv(p->varkind), 0);
HV *elemdesc = TranslateElemDesc(aTHX_ &p->elemdescVar,
pObj, olestash);
hv_store(hv, "elemdescVar", 11, newRV_noinc((SV*)elemdesc), 0);
if (p->varkind == VAR_PERINSTANCE)
hv_store(hv, "oInst", 5, newSViv(p->oInst), 0);
if (p->varkind == VAR_CONST) {
// XXX should be stored as a Win32::OLE::Variant object ?
SV *sv = newSV(0);
SetSVFromVariantEx(aTHX_ p->lpvarValue, sv, olestash);
hv_store(hv, "varValue", 8, sv, 0);
}
pObj->pTypeInfo->ReleaseVarDesc(p);
ST(0) = sv_2mortal(newRV_noinc((SV*)hv));
XSRETURN(1);
}