Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl Monk, Perl Meditation

use C++ COM objects without any compiler

by bulk88 (Priest)
on May 09, 2012 at 02:42 UTC ( #969555=perlmeditation: print w/ replies, xml ) Need Help??

Building upon a hash tree of all OLE enums in a OLE library and SAPI and Win32::OLE's broken WithEvents, here is the challenge. Call "C++ only" COM interfaces without any compiler using a stock Active or Strawberry Perl. Compiling XS code for the COM interface or changing the XS source of any CPAN lib and recompiling is not possible. This node is a combination of a CUFP/Meditation/Tutorial. Alot of my comments and thoughts are in the source code. Your comments are welcome. Your probably a lunatic if you use this in production code (see Yes, even you can use CPAN). I'm probably a lunatic for writing this and releasing it to the masses.

One smart thing MS did, possibly accidentally (openness isn't MS's specialty) that supposedly (I think) all COM methods are __stdcall, not proprietary to the C++ compiler __thiscall/__fastcall. This means all COM interfaces can be called from pure C. Nobody does it. But it is possible. Each COM obj is a pointer to opaque memory block allocated by the COM system, the only part of the memory block that isn't opaque is the 1st member, which is a pointer to a struct/table/array of pointers called a vtable. For example, this is from a code formatted post c-preprocessor output of sapi.h ISpVoice is
typedef struct ISpVoice ISpVoice; typedef struct ISpVoiceVtbl { HRESULT (__stdcall * QueryInterface) (ISpVoice * This, const +IID * const riid, void **ppvObject); ULONG (__stdcall * AddRef) (ISpVoice * This); ULONG (__stdcall * Release) (ISpVoice * This); HRESULT (__stdcall * SetNotifySink) (ISpVoice * This, ISpNoti +fySink * pNotifySink); HRESULT (__stdcall * SetNotifyWindowMessage) (ISpVoice * This +, HWND hWnd, UINT Msg, WPARAM wParam, LPARAM lParam); HRESULT (__stdcall * SetNotifyCallbackFunction) (ISpVoice * T +his, SPNOTIFYCALLBACK * pfnCallback, WPARAM wPara +m, LPARAM lParam); HRESULT (__stdcall * SetNotifyCallbackInterface) (ISpVoice * +This, ISpNotifyCallback * pSpCallback, WPARAM wPar +am, LPARAM lParam); HRESULT (__stdcall * SetNotifyWin32Event) (ISpVoice * This); HRESULT (__stdcall * WaitForNotifyEvent) (ISpVoice * This, DW +ORD dwMilliseconds); HANDLE (__stdcall * GetNotifyEventHandle) (ISpVoice * This); 10HRESULT (__stdcall * SetInterest) (ISpVoice * This, ULONGLO +NG ullEventInterest, ULONGLONG ullQueuedInteres +t); HRESULT (__stdcall * GetEvents) (ISpVoice * This, ULONG ulCou +nt, SPEVENT * pEventArray, ULONG * pulFetched); HRESULT (__stdcall * GetInfo) (ISpVoice * This, SPEVENTSOURCE +INFO * pInfo); HRESULT (__stdcall * SetOutput) (ISpVoice * This, IUnknown * +pUnkOutput, BOOL fAllowFormatChanges); HRESULT (__stdcall * GetOutputObjectToken) (ISpVoice * This, +ISpObjectToken ** ppObjectToken); HRESULT (__stdcall * GetOutputStream) (ISpVoice * This, ISpSt +reamFormat ** ppStream); HRESULT (__stdcall * Pause) (ISpVoice * This); HRESULT (__stdcall * Resume) (ISpVoice * This); 18HRESULT (__stdcall * SetVoice) (ISpVoice * This, ISpObjectT +oken * pToken); HRESULT (__stdcall * GetVoice) (ISpVoice * This, ISpObjectTok +en ** ppToken); HRESULT (__stdcall * Speak) (ISpVoice * This, const WCHAR * p +wcs, DWORD dwFlags, ULONG * pulStreamNumber); HRESULT (__stdcall * SpeakStream) (ISpVoice * This, IStream * + pStream, DWORD dwFlags, ULONG * pulStreamNumber); HRESULT (__stdcall * GetStatus) (ISpVoice * This, SPVOICESTAT +US * pStatus, WCHAR ** ppszLastBookmark); HRESULT (__stdcall * Skip) (ISpVoice * This, WCHAR * pItemTyp +e, long lNumItems, ULONG * pulNumSkipped); HRESULT (__stdcall * SetPriority) (ISpVoice * This, SPVPRIORI +TY ePriority); HRESULT (__stdcall * GetPriority) (ISpVoice * This, SPVPRIORI +TY * pePriority); HRESULT (__stdcall * SetAlertBoundary) (ISpVoice * This, SPEV +ENTENUM eBoundary); HRESULT (__stdcall * GetAlertBoundary) (ISpVoice * This, SPEV +ENTENUM * peBoundary); HRESULT (__stdcall * SetRate) (ISpVoice * This, long RateAdju +st); HRESULT (__stdcall * GetRate) (ISpVoice * This, long *pRateAd +just); HRESULT (__stdcall * SetVolume) (ISpVoice * This, USHORT usVo +lume); HRESULT (__stdcall * GetVolume) (ISpVoice * This, USHORT * pu +sVolume); HRESULT (__stdcall * WaitUntilDone) (ISpVoice * This, ULONG m +sTimeout); HRESULT (__stdcall * SetSyncSpeakTimeout) (ISpVoice * This, U +LONG msTimeout); HRESULT (__stdcall * GetSyncSpeakTimeout) (ISpVoice * This, U +LONG * pmsTimeout); HANDLE (__stdcall * SpeakCompleteEvent) (ISpVoice * This); HRESULT (__stdcall * IsUISupported) (ISpVoice * This, const W +CHAR * pszTypeOfUI, void *pvExtraData, ULONG cbExtraData, BOOL +* pfSupported); HRESULT (__stdcall * DisplayUI) (ISpVoice * This, HWND hwndPa +rent, const WCHAR * pszTitle, const WCHAR * pszTypeOfUI, v +oid *pvExtraData, ULONG cbExtraData); } ISpVoiceVtbl; struct ISpVoice { struct ISpVoiceVtbl *lpVtbl; };
Since all these function pointers are __stdcall, we can use Win32::API to call any of them. Win32::API package gets some runtime modifications to create Win32::API objects that did not come from a DLL. Something Win32::API was never designed to do. The code attempts to be as error catching as possible. It might work on 64 bits but I didn't try it, although provisions are in the code. The biggest nightmare was bugs and quirks with parameter handling and packing problems Win32::API. Notice I'm using DWORD_PTR for pointers, and DWORD for HRESULT for Win32::API prototype purposes.

If someone wants to turn this into a full blown CPAN module, there is no reason they can't theoretically do so. It should be possibly to automatically marshal in pure perl the parameters coming from the function prototype from the COM typelib to Win32::API prototypes. The only thing I check programatically in this script from the typelib C prototype wise is __stdcall-ness of the function. QueryInterface is the C equivalent of a dynamic cast in C++. It generates a new interface pointer to the same COM object. The COM object is conceptual in the COM system, there is no memory or pointer associated with it for practical purposes. 1 COM object has 1 or more "interface" views to it. Each interface is a physical pointer. It is refcounted. When all interface pointers are free/"Release"ed, the conceptual COM object is considered gone. Win32::OLE can only use interfaces that inherit from IDispatch. Each interface AFAIK corresponds to 1 C vtable struct. Each interface must be released when you are done with it. A quick and dirty perl class in my script makes sure the interface pointers dont leak. Regarding Win32::OLE, it is used to create the COM object. Then my script does QueryInterface on that IDispatch (really a ISpeechVoice) interface pointer stored inside the Win32::OLE object to generate a C++ only ISpVoice interface pointer. I didn't try to and didn't research to make a COM object and its initial interface pointer from scratch using Win32::API.

So if you have a Win32::OLE object, but you see some methods in related interfaces using oleview.exe you want to use, but they are C++ only and not accessible using Win32::OLE, you can shouldn't try this at home kids.


I just noticed, the XS portion I converted to almost pure perl, is 2 8x11 pages long. The perl script is 8 8x11 pages long. Shows you that XS is so much faster, easier and better than trying this in Perl.

use strict; no strict "subs"; use Win32::OLE; use Win32::OLE::Const; use Win32::API; use Win32::IPC; use Win32::WinError qw ( E_INVALIDARG S_OK ); #use YourXS; use vars qw( $ptrsize @TYPEKIND @FUNCKIND @CALLCONV ); Win32::OLE->Option(Warn => 3); my $typelib = Win32::OLE::Const->LoadRegTypeLib('Microsoft Speech Obje +ct Library'); my $ISpVoiceDesc = ParseInterface($typelib, 'ISpVoice'); my $vox = Win32::OLE->new ('SAPI.SpVoice') || die "Unable to create SAPI object\n"; #${tied(%{$vox})}{'___Perl___OleObject___'} is the SVIV with WINOLEOBJ +ECT * #see the XS part of the post for what PLCOM is, its just debugging inf +o #YourXS::PLCOM(${tied(%{$vox})}{'___Perl___OleObject___'}); my %SpeechVoiceSpeakFlags = ( "SVSFDefault" => 0, "SVSFIsFilename" => 4, "SVSFIsNotXML" => 16, "SVSFIsXML" => 8, "SVSFNLPMask" => 64, "SVSFNLPSpeakPunc" => 64, "SVSFPersistXML" => 32, "SVSFPurgeBeforeSpeak" => 2, "SVSFUnusedFlags" => -128, "SVSFVoiceMask" => 127, "SVSFlagsAsync" => 1); #IsBadReadPtr is SEH in a simple function, Perl engine has no SEH supp +ort for #catching access vio, someone want to volunteer and send the patch to +P5P? :-) { my $IsBadReadPtr = Win32::API->new( 'kernel32.dll', 'BOOL IsBadReadPtr( UINT_PTR lp, UINT_PTR ucb) +', ); die "getting IsBadReadPtr failed" if !$IsBadReadPtr; sub IsBadReadPtr { return $IsBadReadPtr->Call($_[0], $_[1]); } } package Local::COMInt; sub DESTROY { my $interface = ${$_[0]}; my $funcptr = main::GetVtableFunc($interface, main::IUNKNOWN_QUERY +_INTERFACE_RELEASE()); my $release = main::MkWin32APIObj($funcptr, 'ULONG __stdcall Release (DWORD_PTR This)' ); die "no Release obj " if !$release; print "post release interface refcount is ".$release->Call($interf +ace)."\n"; } package main; #destroy the interface ptr on out of scope my $SpVoicePtr = GetSpVoiceInterface($vox); my $SpVoice = bless(\$SpVoicePtr,'Local::COMInt'); #make 3 Win32::API objs from COM methods then and make Perl friendly w +rappers #yes, I know all 3 functions exist in the IDispatch/VB/ISpeechVoice/Wi +n32::OLE side #thats not the point, point is to call the C++ only side { my $GetVolume = MkWin32APIObj( GetVtableFunc($SpVoice, VtblOffset($ISpVoiceDesc, 'GetVolume') +), #Win32::API doesn't support shorts PDWORD must do 'DWORD __stdcall GetVolume(DWORD_PTR This, PDWORD pusVolume)' ); die "no GV obj " if !$GetVolume; sub GetVolume { my $vol = "\x00\x00"; # a short my $hr = $GetVolume->Call(${$_[0]}, $vol); if($hr == S_OK()){ $_[1] = unpack('v', $vol); } return $hr; } my $SetVolume = MkWin32APIObj( GetVtableFunc($SpVoice, VtblOffset($ISpVoiceDesc, 'SetVolume') +), 'DWORD __stdcall SetVolume(DWORD_PTR This, LONG usVolume)' ); die "no SV obj " if !$SetVolume; sub SetVolume { return $SetVolume->Call(${$_[0]}, $_[1]); } my $SpeakCompleteEvent = MkWin32APIObj(GetVtableFunc($SpVoice, Vtb +lOffset($ISpVoiceDesc, 'SpeakCompleteEvent')), 'DWORD_PTR __stdcall SpeakCompleteEvent (DWORD_PTR This)'); die "no SV obj " if !$SpeakCompleteEvent; sub SpeakCompleteEvent { return bless(\$SpeakCompleteEvent->Call(${$_[0]}), 'Win32::IPC +'); } } my $scEvent = SpeakCompleteEvent($SpVoice); print "SpeakCompleteEvent handle is ${$scEvent}\n"; my ($vol, $hr); $hr = GetVolume($SpVoice, $vol); die "GV failed hr=".sprintf("%x",$hr) if $hr != S_OK(); print "volume is $vol\n"; #do something we can try to get back the number for to prove setvolume + worked $vol--; $hr = SetVolume($SpVoice, $vol); die "SV failed" if $hr != S_OK(); print "set volume to $vol\n"; $hr = GetVolume($SpVoice, $vol); die "GV failed hr=".sprintf("%x",$hr) if $hr != S_OK(); print "volume is $vol\n"; $vol = 101; $hr = SetVolume($SpVoice, $vol); die "SV failed to fail".E_INVALIDARG()." hr =".sprintf("%x", $hr) if $ +hr != E_INVALIDARG(); #see MSDN docs, above 100 is invalid print "failed to set vol above 100 (this is good)\n"; #should still be the value after $vol--; line $hr = GetVolume($SpVoice, $vol); die "GV failed hr=".sprintf("%x",$hr) if $hr != S_OK(); print "volume is $vol\n"; #this is perl right? my $text = "I Love Camels I Love Camels I Love Camels"; my $ret = $vox->Speak ($text, $SpeechVoiceSpeakFlags{"SVSFlagsAsync"}) +; print "Speak function ret=$ret\n"; die "wait operation for Speak Completion failed" if SpeakCompleteEvent($SpVoice)->wait(10000) != 1; print "wait operation for Speak Completion done\n"; # $ISpVoiceIntfPtr = GetSpVoiceInterface($Win32_OLE_Obj_Of_Interface_I +SpeechVoice); sub GetSpVoiceInterface { my $vox = $_[0]; my $voxObj = $vox; my $tmp; if(ref($vox)){ if($tmp = tied(%{$vox})){ if(ref($tmp)){ if(${$tmp}{'___Perl___OleObject___'}){ $vox = ${$tmp}{'___Perl___OleObject___'}; #get IV that is WINOLEOB +JECT * #20 bytes = offsetof(WINOLEOBJECT, pDispatch); //on 32 bit #I assume all smaller type struct members aligned to ptr size on x +64 #6 ptrs is upto and including pDispatch member if(!IsBadReadPtr($vox,$ptrsize*6)){ #check the magic in member "header.lMagic" in struct WINOLEOBJECT #it is the first thing in memory so no byte skipping required $tmp = unpack('L', unpack("P[$ptrsize]", pack('J', $vox))); if($tmp == WINOLE_MAGIC()){#header.lMagic member check print "good ole object\n"; } else{goto NotOLE;} } else{goto NotOLE;} } else{goto NotOLE;} } else{goto NotOLE;} } else{goto NotOLE;} } else{goto NotOLE;} my $dispatch = unpack('x['.($ptrsize*5).']J', unpack('P['.($ptrsiz +e*6).']', pack('J',$vox))); #the 1 member interface struct if(IsBadReadPtr($dispatch,$ptrsize)){goto NotOLE;} my $dispatchQIFunc = GetVtableFunc($dispatch, VtblOffset(#create $interfaceDesc hash tree for ISpeecVoice, ParseInterface(#the $interfaceDesc is only used once for Q +I so dont save it $typelib, #below should evaluate to "ISpeechVoice", do it the long way for modul +arity reasons $voxObj->GetTypeInfo()->_GetDocumentation(-1)->{Name} ), 'QueryInterface' ) #the QI could be hard coded safely, everything inherits from + IUnknown ); my $QueryInterface = MkWin32APIObj($dispatchQIFunc, 'DWORD __stdcall QueryInterface (DWORD_PTR first, LPCSTR riid, DWO +RD_PTR ppvObject)'); die "no QI obj " if !$QueryInterface; #a IID is a pile of longs, shorts, and 6 byte ints in a struct, ea +ch is LE #but a IID is not a 16 byte LE or BE integer as a whole #I just copied this out of pointer memory rather than write a sub +or do another #Win32::API call #the IID as readable string is {6C44DF74-72B9-4992-A1EC-EF996E0422 +D4} my $SpVoiceIID = "\x74\xdf\x44\x6c\xb9\x72\x92\x49\xa1\xec\xef\x99 +\x6e\x04\x22\xd4"; my $SpVoice = "\x00" x PTRSIZE(); #void * as a PV my $SpVoicePtr = unpack('J',pack('P',$SpVoice)); #now an IV that i +s void ** #sanity test against perl engine if(IsBadReadPtr($SpVoicePtr,$ptrsize)){die "pack is broken";} #create new non-IDispatch interface ptr to existing object #from Win32::OLE interface ptr my $hr = $QueryInterface->Call($dispatch, $SpVoiceIID, $SpVoicePtr +); if($hr != S_OK){ die "QI failed HRESULT= $hr"; }#packed void * to IV $SpVoice = unpack('J', $SpVoice); if(!SpVoice){ die "QI returned a null interface ptr"; } return $SpVoice; if(0) { NotOLE: die "not an Win32::OLE object"; } } # $funcptr = GetVtableFunc($interfaceptr, $VtabOffset) sub GetVtableFunc{ my $ptr; #may or may not be a Local::COMInt object if( ref($_[0])){ $ptr = ${$_[0]}; } else{ $ptr = $_[0]; } my $offset = $_[1]; printf("interface %x\n", $ptr); #we are testing the "1 and only member" struct for readability if(IsBadReadPtr($ptr,$ptrsize)){goto badptr;} #getting head of vtable my $lpVtbl = unpack('J', unpack('P['.($ptrsize).']', pack('J',$ptr +))); #checking the vtable for readability if(IsBadReadPtr($lpVtbl,$offset+$ptrsize)){goto badptr;} printf("lpvtbl %x\n", $lpVtbl); #getting the func ptr from vtable my $func = unpack('J', unpack('P['.($ptrsize).']', pack('J',$lpVtb +l+$offset))); printf("func ptr %x\n", $func); #checking first 4 bytes of machine code for readability, #total lenth of machine code of the func can not be determined wit +hout disassembly if(IsBadReadPtr($func,$ptrsize)){goto badptr;} return $func; badptr: die "GetVtableFunc: not an interface ptr"; } BEGIN { #constant and constant processing things our $ptrsize = length(pack('J',0)); eval 'sub PTRSIZE () {'.$ptrsize.'} '; #have to use hard coded because Local::COMInt doesn't know its COM typ +e eval 'sub IUNKNOWN_QUERY_INTERFACE_RELEASE () {'.($ptrsize*3).'}'; sub WINOLE_MAGIC () { 0x12344321 } sub FALSE () { 0 } sub TRUE () { 1 } our @TYPEKIND; our @FUNCKIND; our @CALLCONV; #this block is based off of Win32::OLE::TypeInfo { # Type Kind # --------- sub TKIND_ENUM () { 0; } sub TKIND_RECORD () { TKIND_ENUM() + 1; } sub TKIND_MODULE () { TKIND_RECORD() + 1; } sub TKIND_INTERFACE () { TKIND_MODULE() + 1; } sub TKIND_DISPATCH () { TKIND_INTERFACE() + 1; } sub TKIND_COCLASS () { TKIND_DISPATCH() + 1; } sub TKIND_ALIAS () { TKIND_COCLASS() + 1; } sub TKIND_UNION () { TKIND_ALIAS() + 1; } sub TKIND_MAX () { TKIND_UNION() + 1; } $TYPEKIND[TKIND_ENUM] = 'TKIND_ENUM'; $TYPEKIND[TKIND_RECORD] = 'TKIND_RECORD'; $TYPEKIND[TKIND_MODULE] = 'TKIND_MODULE'; $TYPEKIND[TKIND_INTERFACE] = 'TKIND_INTERFACE'; $TYPEKIND[TKIND_DISPATCH] = 'TKIND_DISPATCH'; $TYPEKIND[TKIND_COCLASS] = 'TKIND_COCLASS'; $TYPEKIND[TKIND_ALIAS] = 'TKIND_ALIAS'; $TYPEKIND[TKIND_UNION] = 'TKIND_UNION'; my %TYPEFLAGS; sub TYPEFLAG_FAPPOBJECT () { 0x1; } sub TYPEFLAG_FCANCREATE () { 0x2; } sub TYPEFLAG_FLICENSED () { 0x4; } sub TYPEFLAG_FPREDECLID () { 0x8; } sub TYPEFLAG_FHIDDEN () { 0x10; } sub TYPEFLAG_FCONTROL () { 0x20; } sub TYPEFLAG_FDUAL () { 0x40; } sub TYPEFLAG_FNONEXTENSIBLE () { 0x80; } sub TYPEFLAG_FOLEAUTOMATION () { 0x100; } sub TYPEFLAG_FRESTRICTED () { 0x200; } sub TYPEFLAG_FAGGREGATABLE () { 0x400; } sub TYPEFLAG_FREPLACEABLE () { 0x800; } sub TYPEFLAG_FDISPATCHABLE () { 0x1000; } sub TYPEFLAG_FREVERSEBIND () { 0x2000; } $TYPEFLAGS{TYPEFLAG_FAPPOBJECT()} = 'TYPEFLAG_FAPPOBJECT'; $TYPEFLAGS{TYPEFLAG_FCANCREATE()} = 'TYPEFLAG_FCANCREATE'; $TYPEFLAGS{TYPEFLAG_FLICENSED()} = 'TYPEFLAG_FLICENSED'; $TYPEFLAGS{TYPEFLAG_FPREDECLID()} = 'TYPEFLAG_FPREDECLID'; $TYPEFLAGS{TYPEFLAG_FHIDDEN()} = 'TYPEFLAG_FHIDDEN'; $TYPEFLAGS{TYPEFLAG_FCONTROL()} = 'TYPEFLAG_FCONTROL'; $TYPEFLAGS{TYPEFLAG_FDUAL()} = 'TYPEFLAG_FDUAL'; $TYPEFLAGS{TYPEFLAG_FNONEXTENSIBLE()} = 'YPEFLAG_FNONEXTENSIBLE'; $TYPEFLAGS{TYPEFLAG_FOLEAUTOMATION()} = 'TYPEFLAG_FOLEAUTOMATION'; $TYPEFLAGS{TYPEFLAG_FRESTRICTED()} = 'TYPEFLAG_FRESTRICTED'; $TYPEFLAGS{TYPEFLAG_FAGGREGATABLE()} = 'TYPEFLAG_FAGGREGATABLE'; $TYPEFLAGS{TYPEFLAG_FREPLACEABLE()} = 'TYPEFLAG_FREPLACEABLE'; $TYPEFLAGS{TYPEFLAG_FDISPATCHABLE()} = 'TYPEFLAG_FDISPATCHABLE'; $TYPEFLAGS{TYPEFLAG_FREVERSEBIND()} = 'TYPEFLAG_FREVERSEBIND'; sub DecodeTYPEFLAGS { my @retarr; for (keys %TYPEFLAGS){ if($_[0] & $_){ push(@retarr, $TYPEFLAGS{$_}); } } return \@retarr; } sub VARFLAG_FREADONLY () { 0x1; } sub VARFLAG_FSOURCE () { 0x2; } sub VARFLAG_FBINDABLE () { 0x4; } sub VARFLAG_FREQUESTEDIT () { 0x8; } sub VARFLAG_FDISPLAYBIND () { 0x10; } sub VARFLAG_FDEFAULTBIND () { 0x20; } sub VARFLAG_FHIDDEN () { 0x40; } sub VARFLAG_FRESTRICTED () { 0x80; } sub VARFLAG_FDEFAULTCOLLELEM () { 0x100; } sub VARFLAG_FUIDEFAULT () { 0x200; } sub VARFLAG_FNONBROWSABLE () { 0x400; } sub VARFLAG_FREPLACEABLE () { 0x800; } sub VARFLAG_FIMMEDIATEBIND () { 0x1000; } my %VARFLAGS; $VARFLAGS{VARFLAG_FREADONLY()} = 'VARFLAG_FREADONLY'; $VARFLAGS{VARFLAG_FSOURCE()} = 'VARFLAG_FSOURCE'; $VARFLAGS{VARFLAG_FBINDABLE()} = 'VARFLAG_FBINDABLE'; $VARFLAGS{VARFLAG_FREQUESTEDIT()} = 'VARFLAG_FREQUESTEDIT'; $VARFLAGS{VARFLAG_FDISPLAYBIND()} = 'VARFLAG_FDISPLAYBIND'; $VARFLAGS{VARFLAG_FDEFAULTBIND()} = 'VARFLAG_FDEFAULTBIND'; $VARFLAGS{VARFLAG_FHIDDEN()} = 'VARFLAG_FHIDDEN'; $VARFLAGS{VARFLAG_FRESTRICTED()} = 'VARFLAG_FRESTRICTED'; $VARFLAGS{VARFLAG_FDEFAULTCOLLELEM()} = 'VARFLAG_FDEFAULTCOLLELEM'; $VARFLAGS{VARFLAG_FUIDEFAULT()} = 'VARFLAG_FUIDEFAULT'; $VARFLAGS{VARFLAG_FNONBROWSABLE()} = 'VARFLAG_FNONBROWSABLE'; $VARFLAGS{VARFLAG_FREPLACEABLE()} = 'VARFLAG_FREPLACEABLE'; $VARFLAGS{VARFLAG_FIMMEDIATEBIND()} = 'VARFLAG_FIMMEDIATEBIND'; sub DecodeVARFLAG { my @retarr; my $flags = $_[0]; foreach(keys %VARFLAGS){ if($flags & $_){ push(@retarr, $VARFLAGS{$_}); $flags = $flags & ~ $_; } } warn "DecodeVARFLAG some flags not decoded unknown" if $flags; return \@retarr; } my @VARKIND; $VARKIND[0] = 'VAR_PERINSTANCE'; $VARKIND[1] = 'VAR_STATIC'; $VARKIND[2] = 'VAR_CONST'; $VARKIND[3] = 'VAR_DISPATCH'; sub DecodeVARKIND { warn "unknown varkind" if ! $VARKIND[$_[0]]; return $VARKIND[$_[0]]; } sub FUNC_VIRTUAL () { 0; } sub FUNC_PUREVIRTUAL () { FUNC_VIRTUAL() + 1; } sub FUNC_NONVIRTUAL () { FUNC_PUREVIRTUAL() + 1; } sub FUNC_STATIC () { FUNC_NONVIRTUAL() + 1; } sub FUNC_DISPATCH () { FUNC_STATIC() + 1; } $FUNCKIND[FUNC_VIRTUAL] = 'FUNC_VIRTUAL'; $FUNCKIND[FUNC_PUREVIRTUAL] = 'FUNC_PUREVIRTUAL'; $FUNCKIND[FUNC_NONVIRTUAL] = 'FUNC_NONVIRTUAL'; $FUNCKIND[FUNC_STATIC] = 'FUNC_STATIC'; $FUNCKIND[FUNC_DISPATCH] = 'FUNC_DISPATCH'; my %INVOKEKIND; sub INVOKE_FUNC () { 1; } sub INVOKE_PROPERTYGET () { 2; } sub INVOKE_PROPERTYPUT () { 4; } sub INVOKE_PROPERTYPUTREF () { 8; } $INVOKEKIND{INVOKE_FUNC()} = 'INVOKE_FUNC'; $INVOKEKIND{INVOKE_PROPERTYGET()} = 'INVOKE_PROPERTYGET'; $INVOKEKIND{INVOKE_PROPERTYPUT()} = 'INVOKE_PROPERTYPUT'; $INVOKEKIND{INVOKE_PROPERTYPUTREF()} = 'INVOKE_PROPERTYPUTREF'; sub DecodeINVOKEKIND { my @retarr; my $flags = $_[0]; foreach(keys %INVOKEKIND){ if($flags & $_){ push(@retarr, $INVOKEKIND{$_}); $flags = $flags & ~ $_; } } warn "DecodeINVOKEKIND some flags not decoded unknown" if $flags; return \@retarr; } # Calling conventions # ------------------- sub CC_FASTCALL () { 0; } sub CC_CDECL () { 1; } sub CC_MSCPASCAL () { CC_CDECL() + 1; } sub CC_PASCAL () { CC_MSCPASCAL; } sub CC_MACPASCAL () { CC_PASCAL() + 1; } sub CC_STDCALL () { CC_MACPASCAL() + 1; } sub CC_FPFASTCALL () { CC_STDCALL() + 1; } sub CC_SYSCALL () { CC_FPFASTCALL() + 1; } sub CC_MPWCDECL () { CC_SYSCALL() + 1; } sub CC_MPWPASCAL () { CC_MPWCDECL() + 1; } sub CC_MAX () { CC_MPWPASCAL() + 1; } $CALLCONV[CC_FASTCALL] = 'CC_FASTCALL'; $CALLCONV[CC_CDECL] = 'CC_CDECL'; $CALLCONV[CC_PASCAL] = 'CC_PASCAL'; $CALLCONV[CC_MACPASCAL] = 'CC_MACPASCAL'; $CALLCONV[CC_STDCALL] = 'CC_STDCALL'; $CALLCONV[CC_FPFASTCALL] = 'CC_FPFASTCALL'; $CALLCONV[CC_SYSCALL] = 'CC_SYSCALL'; $CALLCONV[CC_MPWCDECL] = 'CC_MPWCDECL'; $CALLCONV[CC_MPWPASCAL] = 'CC_MPWPASCAL'; } } #end of BEGIN # $vtableoffset = VtblOffset($interfaceDesc, $funcName); sub VtblOffset { my($interfaceDesc, $funcName) = @_; die "Function $funcName doesn't exist in Interface ".$interfaceDes +c->{'Docs'}->{'Name'} if ! exists($interfaceDesc->{'Funcs'}->{$funcName}); die "Function is not __stdcall" if $interfaceDesc->{'Funcs'}->{$funcName}->{'callconv'} ne 'CC_ST +DCALL'; return $interfaceDesc->{'Funcs'}->{$funcName}->{'oVft'}; } # $interfaceDesc = ParseInterface($typelib, $interfaceName); sub ParseInterface{ die 'wrong usage' if scalar(@_) != 2; my($typelib, $interfaceName) = @_; my $typeinfo = $typelib->GetTypeInfo($interfaceName); my $typeinfohash = $typeinfo->_GetDocumentation(-1); my $attrs = $typeinfo->_GetTypeAttr(); $attrs->{'typekind'} = $TYPEKIND[$attrs->{'typekind'}]; $attrs->{'wTypeFlags'} = DecodeTYPEFLAGS($attrs->{'wTypeFlags'}); $attrs->{'Docs'} = $typeinfohash; if($attrs->{'cFuncs'}){ AddFuncsFromTypeInfo($typeinfo, $attrs); } else{ die "interface contains no funcs"; } #the interface hash tree's attributes slices (non {'Funcs'} slices +) #are from the "official" interface not from any inherited interfac +es return $attrs; } # void AddFuncsFromTypeInfo($typeinfo, $hashref) sub AddFuncsFromTypeInfo{ die "wrong usage" if @_ != 2; my ($typeinfo, $hashref) = @_; my $attrs = $typeinfo->_GetTypeAttr(); my $typeinfohash = $typeinfo->_GetDocumentation(-1); #this should be impossible, IDK if it is die "a VERY interesting typeinfo" if ($attrs->{'cVars'} && $attrs->{'cFuncs'}); #can't call _GetFuncDesc if this typeinfo has no functions if($attrs->{'cFuncs'}){ for(0..$attrs->{'cFuncs'}-1){ my $funcdesc = $typeinfo->_GetFuncDesc($_); $funcdesc->{'funckind'} = @FUNCKIND[$funcdesc->{'funckind' +}]; $funcdesc->{'callconv'} = @CALLCONV[$funcdesc->{'callconv' +}]; $funcdesc->{'invkind'} = DecodeINVOKEKIND($funcdesc->{'inv +kind'}); $funcdesc->{'InterfaceName'} = $typeinfohash->{'Name'}; $hashref->{'Funcs'}->{ $typeinfo->_GetDocumentation($funcdesc->{'memid'})->{' +Name'} } = $funcdesc; } } #be recursive on inherited interfaces, the function slices are all + flat #the inheritance tree is not kept, one vtable can consist of many +inherited #interfaces, we want a list of every func on the vtable, $attrs->{ +'cImplTypes'} #should always be true, except IUnknown, since everything inherit +s an IUnknown #IDK if $attrs->{'cImplTypes'} can ever be anything but 1 or 0 if($attrs->{'cImplTypes'}){ for(0..$attrs->{'cImplTypes'}-1){ AddFuncsFromTypeInfo($typeinfo->_GetImplTypeInfo($_), $has +href); } } } # $Win32APIObj = MkWin32APIObj($funcptr, $funcProtoStr); sub MkWin32APIObj { my $funcptr = $_[0]; #no XS/C code allowed, pun intended local(*Win32::API::GetProcAddress); local(*Win32::API::LoadLibrary); #sanity check if(IsBadReadPtr($_[0],$ptrsize)){die "Can't make a Win32::API to a + bad func ptr";} *Win32::API::GetProcAddress = sub { return $funcptr; #IV not a pack() style ptr }; *Win32::API::LoadLibrary = sub { return 1; #special constant to the new Win32::API::FreeLibrary + below }; return Win32::API->new("\0", $_[1]);#null path can never be a work +ing path } BEGIN { #this is permanent, not localized my $realFreeLibrary = \&Win32::API::FreeLibrary; *Win32::API::FreeLibrary = sub { if($_[0] != 1) { return &{$realFreeLibrary}($_[0]); } else { return TRUE ;} } }
optional and not enabled above XS stuff
//a c file. #include it in the XS file static char szWINOLE[] = "Win32::OLE"; 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; #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 typedef struct { OBJECTHEADER header; UV flags; IDispatch *pDispatch; ITypeInfo *pTypeInfo; IEnumVARIANT *pEnum; void *pEventSink; HV *self; HV *hashTable; SV *destroy; unsigned short cFuncs; unsigned short cVars; unsigned int PropIndex; } WINOLEOBJECT; void PLCOM(pTHX_ SV * sv){ WINOLEOBJECT *pObj; ISpVoice * SpVInterface; HRESULT hr; unsigned short vol; int dispatchpos = offsetof (WINOLEOBJECT, pDispatch); pObj = (WINOLEOBJECT*)(SvIV(sv)); if (pObj->header.lMagic != WINOLE_MAGIC || !(pObj->pDispatch)){ croak("PLCOM: GetOleObject() Not a %s object", szWINOLE); } hr = pObj->pDispatch->lpVtbl->QueryInterface(pObj->pDispatch, &IID +_ISpVoice, (void **)&SpVInterface); printf("from c QI pdispath=%p lpvtbl=%p QI=%p\n", pObj->pDispatch, pObj->pDispatch->lpVtbl, pObj->pDispatch->lpVtbl->QueryInterface); if(hr != S_OK) croak("QueryInterface Failed"); hr = SpVInterface->lpVtbl->GetVolume(SpVInterface, &vol); if(hr != S_OK) croak("GetVolume Failed"); vol--; hr = SpVInterface->lpVtbl->SetVolume(SpVInterface, vol); if(hr != S_OK) croak("SetVolume Failed"); vol = 0; hr = SpVInterface->lpVtbl->GetVolume(SpVInterface, &vol); if(hr != S_OK) croak("GetVolume Failed"); printf("from c GV pdispath=%p lpvtbl=%p GV=%p\n", SpVInterface, SpVInterface->lpVtbl, SpVInterface->lpVtbl->GetVolume); printf("from c SV pdispath=%p lpvtbl=%p SV=%p\n", SpVInterface, SpVInterface->lpVtbl, SpVInterface->lpVtbl->SetVolume); hr = SpVInterface->lpVtbl->Release(SpVInterface); 0; } ##################################################################### //In the XS file void PLCOM(sv) SV * sv PPCODE: PLCOM(aTHX_ sv);
Output of the script.
C:\Documents and Settings\Owner\Desktop>perl good ole object interface c43d24 lpvtbl 6d6e6818 func ptr 6d718879 interface c43d18 lpvtbl 6d6e68b8 func ptr 6d736908 interface c43d18 lpvtbl 6d6e68b8 func ptr 6d73688f interface c43d18 lpvtbl 6d6e68b8 func ptr 6d735082 SpeakCompleteEvent handle is 1748 volume is 100 set volume to 99 volume is 99 failed to set vol above 100 (this is good) volume is 99 Speak function ret=1 wait operation for Speak Completion done interface c43d18 lpvtbl 6d6e68b8 func ptr 6d718722 post release interface refcount is 0 C:\Documents and Settings\Owner\Desktop>

Comment on use C++ COM objects without any compiler
Select or Download Code
Replies are listed 'Best First'.
Re: use C++ COM objects without any compiler
by Anonymous Monk on May 09, 2012 at 11:43 UTC

    I just noticed, the XS portion I converted to almost pure perl, is 2 8x11 pages long. The perl script is 8 8x11 pages long. Shows you that XS is so much faster, easier and better than trying this in Perl.

    Well, at least 5 pages of that is CONSTANTS, and at least one page is , unexplained Win32::API overrides and C-style if/else block

Log In?

What's my password?
Create A New User
Node Status?
node history
Node Type: perlmeditation [id://969555]
Approved by davido
Front-paged by Arunbear
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others taking refuge in the Monastery: (6)
As of 2015-11-28 18:24 GMT
Find Nodes?
    Voting Booth?

    What would be the most significant thing to happen if a rope (or wire) tied the Earth and the Moon together?

    Results (743 votes), past polls