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 ;}
    }
}