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, ISpNotifySink * pNotifySink);

         HRESULT (__stdcall * SetNotifyWindowMessage) (ISpVoice * This, HWND hWnd, UINT Msg, WPARAM wParam,
                                                       LPARAM lParam);

         HRESULT (__stdcall * SetNotifyCallbackFunction) (ISpVoice * This, SPNOTIFYCALLBACK * pfnCallback,
                                                          WPARAM wParam, LPARAM lParam);

         HRESULT (__stdcall * SetNotifyCallbackInterface) (ISpVoice * This, ISpNotifyCallback * pSpCallback,
                                                           WPARAM wParam, LPARAM lParam);

         HRESULT (__stdcall * SetNotifyWin32Event) (ISpVoice * This);

         HRESULT (__stdcall * WaitForNotifyEvent) (ISpVoice * This, DWORD dwMilliseconds);

         HANDLE (__stdcall * GetNotifyEventHandle) (ISpVoice * This);

         10HRESULT (__stdcall * SetInterest) (ISpVoice * This, ULONGLONG ullEventInterest,
                                            ULONGLONG ullQueuedInterest);

         HRESULT (__stdcall * GetEvents) (ISpVoice * This, ULONG ulCount, SPEVENT * pEventArray,
                                          ULONG * pulFetched);

         HRESULT (__stdcall * GetInfo) (ISpVoice * This, SPEVENTSOURCEINFO * pInfo);

         HRESULT (__stdcall * SetOutput) (ISpVoice * This, IUnknown * pUnkOutput, BOOL fAllowFormatChanges);

         HRESULT (__stdcall * GetOutputObjectToken) (ISpVoice * This, ISpObjectToken ** ppObjectToken);

         HRESULT (__stdcall * GetOutputStream) (ISpVoice * This, ISpStreamFormat ** ppStream);

         HRESULT (__stdcall * Pause) (ISpVoice * This);

         HRESULT (__stdcall * Resume) (ISpVoice * This);

         18HRESULT (__stdcall * SetVoice) (ISpVoice * This, ISpObjectToken * pToken);

         HRESULT (__stdcall * GetVoice) (ISpVoice * This, ISpObjectToken ** ppToken);

         HRESULT (__stdcall * Speak) (ISpVoice * This, const WCHAR * pwcs, DWORD dwFlags,
                                      ULONG * pulStreamNumber);

         HRESULT (__stdcall * SpeakStream) (ISpVoice * This, IStream * pStream, DWORD dwFlags,
                                            ULONG * pulStreamNumber);

         HRESULT (__stdcall * GetStatus) (ISpVoice * This, SPVOICESTATUS * pStatus,
                                          WCHAR ** ppszLastBookmark);

         HRESULT (__stdcall * Skip) (ISpVoice * This, WCHAR * pItemType, long lNumItems,
                                     ULONG * pulNumSkipped);

         HRESULT (__stdcall * SetPriority) (ISpVoice * This, SPVPRIORITY ePriority);

         HRESULT (__stdcall * GetPriority) (ISpVoice * This, SPVPRIORITY * pePriority);

         HRESULT (__stdcall * SetAlertBoundary) (ISpVoice * This, SPEVENTENUM eBoundary);

         HRESULT (__stdcall * GetAlertBoundary) (ISpVoice * This, SPEVENTENUM * peBoundary);

         HRESULT (__stdcall * SetRate) (ISpVoice * This, long RateAdjust);

         HRESULT (__stdcall * GetRate) (ISpVoice * This, long *pRateAdjust);

         HRESULT (__stdcall * SetVolume) (ISpVoice * This, USHORT usVolume);

         HRESULT (__stdcall * GetVolume) (ISpVoice * This, USHORT * pusVolume);

         HRESULT (__stdcall * WaitUntilDone) (ISpVoice * This, ULONG msTimeout);

         HRESULT (__stdcall * SetSyncSpeakTimeout) (ISpVoice * This, ULONG msTimeout);

         HRESULT (__stdcall * GetSyncSpeakTimeout) (ISpVoice * This, ULONG * pmsTimeout);

         HANDLE (__stdcall * SpeakCompleteEvent) (ISpVoice * This);

         HRESULT (__stdcall * IsUISupported) (ISpVoice * This, const WCHAR * pszTypeOfUI, void *pvExtraData,
                                              ULONG cbExtraData, BOOL * pfSupported);

         HRESULT (__stdcall * DisplayUI) (ISpVoice * This, HWND hwndParent, const WCHAR * pszTitle,
                                          const WCHAR * pszTypeOfUI, void *pvExtraData, ULONG cbExtraData);

     } ISpVoiceVtbl;

     struct ISpVoice
     {
         struct ISpVoiceVtbl *lpVtbl;
     };

##</code><code>##

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 Object 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 WINOLEOBJECT *
#see the XS part of the post for what PLCOM is, its just debugging info
#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 support 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($interface)."\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 wrappers
#yes, I know all 3 functions exist in the IDispatch/VB/ISpeechVoice/Win32::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, VtblOffset($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_ISpeechVoice);
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 WINOLEOBJECT *
    #20 bytes = offsetof(WINOLEOBJECT, pDispatch);  //on 32 bit 
    #I assume all smaller type struct members aligned to ptr size on x64
    #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['.($ptrsize*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 QI so dont save it
                $typelib,
#below should evaluate to "ISpeechVoice", do it the long way for modularity 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, DWORD_PTR ppvObject)');
    die "no QI obj " if !$QueryInterface;
    #a IID is a pile of longs, shorts, and 6 byte ints in a struct, each 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-EF996E0422D4}
    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 is 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',$lpVtbl+$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 without 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 type
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 ".$interfaceDesc->{'Docs'}->{'Name'}
        if ! exists($interfaceDesc->{'Funcs'}->{$funcName});
    die "Function is not __stdcall" if 
        $interfaceDesc->{'Funcs'}->{$funcName}->{'callconv'} ne 'CC_STDCALL';
    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 interfaces
    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->{'invkind'});
            $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 inherits 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($_), $hashref);
        }
    }
}


# $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 working 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 ;}
    }
}


##</code><code>##

//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);

##</code><code>##

C:\Documents and Settings\Owner\Desktop>perl  sapi2pm.pl
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>