diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Win32/API/Callback.pm')
| -rw-r--r-- | Master/tlpkg/tlperl/lib/Win32/API/Callback.pm | 502 |
1 files changed, 451 insertions, 51 deletions
diff --git a/Master/tlpkg/tlperl/lib/Win32/API/Callback.pm b/Master/tlpkg/tlperl/lib/Win32/API/Callback.pm index 46879b4041b..b96d938265e 100644 --- a/Master/tlpkg/tlperl/lib/Win32/API/Callback.pm +++ b/Master/tlpkg/tlperl/lib/Win32/API/Callback.pm @@ -6,17 +6,23 @@ # Win32::API::Callback - Perl Win32 API Import Facility # # Author: Aldo Calpini <dada@perl.it> +# Author: Daniel Dragan <bulkdd@cpan.org> # Maintainer: Cosimo Streppone <cosimo@cpan.org> # ####################################################################### package Win32::API::Callback; +use strict; +use warnings; +use vars qw( $VERSION @ISA $Stage2FuncPtrPkd ); + +$VERSION = '0.77'; -$VERSION = '0.68'; require Exporter; # to export the constants to the main:: space require DynaLoader; # to dynuhlode the module. @ISA = qw( Exporter DynaLoader ); +#use Data::Dumper; sub DEBUG { if ($WIN32::API::DEBUG) { @@ -27,39 +33,32 @@ sub DEBUG { } } -use Win32::API; +use Win32::API qw ( WriteMemory ) ; use Win32::API::Type; -use Win32::API::Struct; - -####################################################################### -# This AUTOLOAD is used to 'autoload' constants from the constant() -# XS function. If a constant is not found then control is passed -# to the AUTOLOAD in AutoLoader. -# - -sub AUTOLOAD { - my ($constname); - ($constname = $AUTOLOAD) =~ s/.*:://; - - #reset $! to zero to reset any current errors. - $! = 0; - my $val = constant($constname, @_ ? $_[0] : 0); - if ($! != 0) { - if ($! =~ /Invalid/) { - $AutoLoader::AUTOLOAD = $AUTOLOAD; - goto &AutoLoader::AUTOLOAD; - } - else { - ($pack, $file, $line) = caller; - die - "Your vendor has not defined Win32::API::Callback macro $constname, used at $file line $line."; - } +use Config; +#use Win32::API::Struct; #not implemented + + +BEGIN { + #there is supposed to be 64 bit IVs on 32 bit perl compatibility here + #but it is untested + #Win64 added in 5.7.3 + eval "sub IVSIZE () { ".length(pack($] >= 5.007003 ? 'J' : 'I' ,0))." }"; + #what kind of stack processing/calling convention/machine code we needed + eval "sub ISX64 () { ".(Win32::API::PTRSIZE() == 8 ? 1 : 0)." }"; + eval 'sub OPV () {'.$].'}'; + sub OPV(); + sub CONTEXT_XMM0(); + sub CONTEXT_RAX(); + *IsBadStringPtr = *Win32::API::IsBadStringPtr; + sub PTRSIZE (); + *PTRSIZE = *Win32::API::PTRSIZE; + sub PTRLET (); + *PTRLET = *Win32::API::Type::pointer_pack_type; + if(OPV <= 5.008000){ #don't have unpackstring in C + eval('sub _CallUnpack {return unpack($_[0], $_[1]);}'); } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; } - - ####################################################################### # dynamically load in the API extension module. # @@ -69,41 +68,44 @@ bootstrap Win32::API::Callback; # PUBLIC METHODS # sub new { - my ($class, $proc, $in, $out) = @_; - my %self = (); - + my ($class, $proc, $in, $out, $callconvention) = @_; + my $self = bless {}, $class; #about croak/die safety, can safely bless here, + #a ::Callback has no DESTROY, it has no resources to release, there is a HeapBlock obj + #stored in the ::Callback hash, but the HeapBlock destroys on its own # printf "(PM)Callback::new: got proc='%s', in='%s', out='%s'\n", $proc, $in, $out; - $self{in} = []; + $self->{intypes} = []; #XS requires this, do not remove if (ref($in) eq 'ARRAY') { foreach (@$in) { - push(@{$self{in}}, Win32::API::type_to_num($_)); + push(@{$self->{intypes}}, $_); } } else { my @in = split '', $in; foreach (@in) { - push(@{$self{in}}, Win32::API::type_to_num($_)); + push(@{$self->{intypes}}, $_); + } + } + $self->{inbytes} = 0; + foreach(@{$self->{intypes}}){ #calc how long the c stack is + if($_ eq 'Q' or $_ eq 'q' or $_ eq 'D' or $_ eq 'd'){ + $self->{inbytes} += 8; #always 8 + } + else{ + $self->{inbytes} += PTRSIZE; #4 or 8 } } - $self{out} = Win32::API::type_to_num($out); - $self{sub} = $proc; - my $self = bless \%self, $class; + $self->{outtype} = $out; + $self->{out} = Win32::API->type_to_num($out); + $self->{sub} = $proc; + $self->{cdecl} = Win32::API::calltype_to_num($callconvention); DEBUG "(PM)Callback::new: calling CallbackCreate($self)...\n"; - my $hproc = CallbackCreate($self); + my $hproc = MakeCB($self); DEBUG "(PM)Callback::new: hproc=$hproc\n"; - #### ...if that fails, set $! accordingly - if (!$hproc) { - $! = Win32::GetLastError(); - return undef; - } - - #### ok, let's stuff the object $self->{code} = $hproc; - $self->{sub} = $proc; #### cast the spell return $self; @@ -117,6 +119,309 @@ sub MakeStruct { return $struct; } +#this was rewritten in XS, and is broken b/c it doesn't work on 32bit Perl with Quads +#sub MakeParamArr { #on x64, never do "$i++; $packedparam .= $arr->[$i];" +# #on x86, structs and over word size params appears on the stack, +# #on x64 anything over the size of a "word" is passed by pointer +# #nothing takes more than 8 bytes per parameter on x64 +# #there is no way to formally specify a pass by copy struct in ::Callback +# #this only matters on x86, a work around is a bunch of N/I parameters, +# #repack them as Js, then concat them, and you have the original pass by copy +# #x86 struct +# my ($self, $arr) = @_; +# my ($i, @pass_arr) = (0); +# for(@{$self->{intypes}}){ #elements of intypes are not 1 to 1 with stack params +# my ($typeletter, $packedparam, $finalParam, $unpackletter) = ($_, $arr->[$i]); +# +# #structs don't work, this is broken code from old version +# #$self->{intypes} is letters types not C prototype params +# #C prototype support would have to exist for MakeStruct to work +# if( $typeletter eq 'S' || $typeletter eq 's'){ +# die "Win32::API::Callback::MakeParamArr type letter \"S\" and struct support not implemented"; +# #push(@pass_arr, MakeStruct($self, $i, $packedparam)); +# }elsif($typeletter eq 'I'){ +# $unpackletter = 'I', goto UNPACK; +# }elsif($typeletter eq 'i'){ +# $unpackletter = 'i', goto UNPACK; +# }elsif($typeletter eq 'f' || $typeletter eq 'F'){ +# $unpackletter = 'f', goto UNPACK; +# } +# elsif($typeletter eq 'd' || $typeletter eq 'D'){ +# if(IVSIZE == 4){ #need more data, 32 bit machine +# $packedparam .= $arr->[++$i]; +# } +# $unpackletter = 'd', goto UNPACK; +# } +# elsif($typeletter eq 'N' || $typeletter eq 'L' #on x64, J is 8 bytes +# || (IVSIZE == 8 ? $typeletter eq 'Q': 0)){ +# $unpackletter = 'J', goto UNPACK; +# }elsif($typeletter eq 'n' || $typeletter eq 'l' +# || (IVSIZE == 8 ? $typeletter eq 'q': 0)){ +# $unpackletter = 'j', goto UNPACK; +# }elsif(IVSIZE == 4 && ($typeletter eq 'q' || $typeletter eq 'Q')){ +# #need more data, 32 bit machine +# $finalParam = $packedparam . $arr->[++$i]; +# }elsif($typeletter eq 'p' || $typeletter eq 'P'){ +# if(!IsBadStringPtr($arr->[$i], ~0)){ #P letter is terrible design +# $unpackletter = 'p', goto UNPACK; +# }#else undef +# } +# else{ die "Win32::API::Callback::MakeParamArr unknown in type letter $typeletter";} +# goto GOTPARAM; +# UNPACK: +# $finalParam = unpack($unpackletter, $packedparam); +# GOTPARAM: +# $i++; +# push(@pass_arr, $finalParam); +# } +# return \@pass_arr; +#} + +#on x64 +#void RunCB($self, $EBP_ESP, $retval) +#on x86 +#void RunCB($self, $EBP_ESP, $retval, $unwindcount, $F_or_D) +if(! ISX64 ) { +*RunCB = sub {#32 bits + my $self = $_[0]; + my (@pass_arr, $return, $typeletter, $inbytes, @arr); + $inbytes = $self->{inbytes}; + #first is ebp copy then ret address + $inbytes += PTRSIZE * 2; + my $paramcount = $inbytes / PTRSIZE ; + my $stackstr = unpack('P'.$inbytes, pack(PTRLET, $_[1])); + #pack () were added in 5.7.2 + if (OPV > 5.007002) { + @arr = unpack("(a[".PTRLET."])[$paramcount]",$stackstr); + } else { + #letter can not be used for size, must be numeric on 5.6 + @arr = unpack(("a4") x $paramcount,$stackstr); + } + shift @arr, shift @arr; #remove ebp copy and ret address + $paramcount -= 2; + $return = &{$self->{sub}}(@{MakeParamArr($self, \@arr)}); + + #now the return type + $typeletter = $self->{outtype}; + #float_or_double flag, its always used + #float is default for faster copy of probably unused value + $_[4] = 0; + #its all the same in memory + if($typeletter eq 'n' || $typeletter eq 'N' + || $typeletter eq 'l' || $typeletter eq 'L' + || $typeletter eq 'i' || $typeletter eq 'I'){ + $_[2] = pack(PTRLET, $return); + }elsif($typeletter eq 'q' || $typeletter eq 'Q'){ + if(IVSIZE == 4){ + if($self->{'UseMI64'} || ref($return)){ #un/signed meaningless + $_[2] = Math::Int64::int64_to_native($return); + } + else{ + warn("Win32::API::Callback::RunCB return value for return type Q is under 8 bytes long") + if length($return) < 8; + $_[2] = $return.''; #$return should be a 8 byte string + #will be garbage padded in XS if < 8, but must be a string, not a IV or under + } + } + else{ + $_[2] = pack($typeletter, $return); + } + }elsif($typeletter eq 'f' || $typeletter eq 'F' ){ + $_[2] = pack('f', $return); + }elsif($typeletter eq 'd' || $typeletter eq 'D' ){ + $_[2] = pack('d', $return); + $_[4] = 1; #use double + }else { #return null + $_[2] = "\x00" x 8; + } + + if(! $self->{cdecl}){ + $_[3] = PTRSIZE * $paramcount; #stack rewind amount in bytes + } + else{$_[3] = 0;} +}; +} +else{ #64 bits +*RunCB = sub { + my $self = $_[0]; + my (@pass_arr, $return, $typeletter); + my $paramcount = $self->{inbytes} / IVSIZE; + my $stack_ptr = unpack('P[J]', pack('J', ($_[1]+CONTEXT_RAX()))); + my $stack_str = unpack('P['.$self->{inbytes}.']', $stack_ptr); + my @stack_arr = unpack("(a[J])[$paramcount]",$stack_str); + #not very efficient, todo search for f/F/d/D in new() not here + my $XMMStr = unpack('P['.(4 * 16).']', pack('J', ($_[1]+CONTEXT_XMM0()))); + #print Dumper([unpack('(H[32])[4]', $XMMStr)]); + my @XMM = unpack('(a[16])[4]', $XMMStr); + #assume registers are copied to shadow stack space already + #because of ... prototype, so only XMM registers need to be fetched. + #Limitation, vararg funcs on x64 get floating points in normal registers + #not XMMs, so a vararg function taking floats and doubles in the first 4 + #parameters isn't supported + if($paramcount){ + for(0..($paramcount > 4 ? 4 : $paramcount)-1){ + my $typeletter = ${$self->{intypes}}[$_]; + if($typeletter eq 'f' || $typeletter eq 'F' || $typeletter eq 'd' + || $typeletter eq 'D'){ + #x64 calling convention does not use the high 64 bits of a XMM register + #although right here the high 64 bits are in @XMM elements + #J on x64 is 8 bytes, a double will not corrupt, this is unreachable on x86 + #note we are copying 16 bytes elements to @stack_arr, @stack_arr is + #normally 8 byte elements, unpack ignores the excess bytes later + $stack_arr[$_] = $XMM[$_]; + } + } + } + #print Dumper(\@stack_arr); + #print Dumper(\@XMM); + $return = &{$self->{sub}}(@{MakeParamArr($self, \@stack_arr)}); + + #now the return type + $typeletter = $self->{outtype}; + #its all the same in memory + if($typeletter eq 'n' || $typeletter eq 'N' + || $typeletter eq 'l' || $typeletter eq 'L' + || $typeletter eq 'i' || $typeletter eq 'I' + || $typeletter eq 'q' || $typeletter eq 'Q'){ + $_[2] = pack('J', $return); + } + elsif($typeletter eq 'f' || $typeletter eq 'F' ){ + $_[2] = pack('f', $return); + } + elsif($typeletter eq 'd' || $typeletter eq 'D' ){ + $_[2] = pack('d', $return); + } + else { #return null + $_[2] = pack('J', 0); + } +}; +} + +sub MakeCB{ + + my $self = $_[0]; + #this x86 function does not corrupt the callstack in a debugger since it + #uses ebp and saves ebp on the stack, the function won't have a pretty + #name though + my $code = (!ISX64) ? ('' #parenthesis required to constant fold + ."\x55" # push ebp + ."\x8B\xEC" # mov ebp, esp + ."\x83\xEC\x0C"# sub esp, 0Ch + ."\x8D\x45\xFC" # lea eax, [ebp+FuncRtnCxtVar] + ."\x50"# push eax + ."\x8D\x45\xF4"# lea eax, [ebp+retval] + ."\x50"# push eax + ."\x8B\xC5"# mov eax,ebp + ."\x50"# push eax + ."\xB8").PackedRVTarget($self)#B8 mov imm32 to eax, a HV * winds up here + .("\x50"# push eax + ."\xB8").$Stage2FuncPtrPkd # mov eax, 0C0DE0001h + .("\xFF\xD0"# call eax + #since ST(0) is volatile, we don't care if we fill it with garbage + ."\x80\x7D\xFE\x00"#cmp [ebp+FuncRtnCxtVar.F_Or_D], 0 + ."\x74\x05"# jz 5 bytes + ."\xDD\x45\xF4"# fld qword ptr [ebp+retval] (double) + ."\xEB\x03"# jmp 3 bytes + ."\xD9\x45\xF4"# fld dword ptr [ebp+retval] (float) + #rewind sp to entry sp, no pop push after this point + ."\x83\xC4\x24"# add esp, 24h + ."\x8B\x45\xF4"# mov eax, dword ptr [ebp+retval] + #edx might be garbage, we don't care, caller only looks at volatile + #registers that the caller's prototype says the caller does + ."\x8B\x55\xF8"# mov edx, dword ptr [ebp+retval+4] + #can't use retn op, it requires a immediate count, our count is in a register + #only one register available now, this will be complicated + ."\x0F\xB7\x4D\xFC"#movzx ecx, word ptr [ebp+FuncRtnCxtVar.unwind_len] + ."\x01\xCC"# add esp, ecx , might be zero or more + ."\x8B\x4D\x04"# mov ecx, dword ptr [ebp+4] ret address + ."\x8B\x6D\x00"# mov ebp, dword ptr [ebp+0] restore BP + ."\xFF\xE1")# jmp ecx + + + #begin x64 part + #these packs don't constant fold in < 5.17 :-( + #they are here for readability + :(''.pack('C', 0b01000000 #REX base + | 0b00001000 #REX.W + | 0b00000001 #REX.B + ).pack('C', 0xB8+2) #mov to r10 register + .PackedRVTarget($self) + .pack('C', 0b01000000 #REX base + | 0b00001000 #REX.W + ).pack('C', 0xB8) #mov to rax register + .$Stage2FuncPtrPkd + ."\xFF\xE0");# jmp rax +#making a full function in Perl in x64 was removed because RtlAddFunctionTable +#has no effect on VS 2008 debugger, it is a bug in VS 2008, in WinDbg the C callstack +#is correct with RtlAddFunctionTable, and broken without RtlAddFunctionTable +#in VS 2008, the C callstack was always broken since WinDbg and VS 2008 both +#*only* use Unwind Tables on x64 to calculate C callstacks, they do not, I think, +#use 32 bit style EBP/RBP walking, x64 VC almost never uses BP addressing anyway. +#The easiest fix was to not have dynamic machine code in the callstack at all, +#which is what I did. Having good C callstacks in a debugger with ::API and +#::Callback are a good goal. +# +##--- c:\documents and settings\administrator\desktop\w32api\callback\callback.c - +# $code .= "\x4C\x8B\xDC";# mov r11,rsp +# $code .= "\x49\x89\x4B\x08";# mov qword ptr [r11+8],rcx +# $code .= "\x49\x89\x53\x10";# mov qword ptr [r11+10h],rdx +# $code .= "\x4D\x89\x43\x18";# mov qword ptr [r11+18h],r8 +# $code .= "\x4D\x89\x4B\x20";# mov qword ptr [r11+20h],r9 +# $code .= "\x48\x83\xEC\x78";# sub rsp,78h +# #void (*LPerlCallback)(SV *, void *, unsigned __int64 *, void *) = +# #( void (*)(SV *, void *, unsigned __int64 *, void *)) 0xC0DE00FFFF000001; +# #__m128 arr [4]; +# #__m128 retval; +## arr[0].m128_u64[0] = 0xFFFF00000000FF10; +##00000000022D1017 48 B8 10 FF 00 00 00 00 FF FF mov rax,0FFFF00000000FF10h +##arr[0].m128_u64[1] = 0xFFFF00000000FF11; +## arr[1].m128_u64[0] = 0xFFFF00000000FF20; +## arr[1].m128_u64[1] = 0xFFFF00000000FF21; +## arr[2].m128_u64[0] = 0xFFFF00000000FF30; +## arr[2].m128_u64[1] = 0xFFFF00000000FF31; +## arr[3].m128_u64[0] = 0xFFFF00000000FF40; +## arr[3].m128_u64[1] = 0xFFFF00000000FF41; +# +## LPerlCallback((SV *)0xC0DE00FFFF000002, (void*) arr, (unsigned __int64 *)&retval, +## (DWORD_PTR)&a); +##00000000022D1021 4D 8D 4B 08 lea r9,[r11+8] #no 4th param +# $code .= "\x4D\x8D\x43\xA8";# lea r8,[r11-58h] #&retval param +##00000000022D1029 49 89 43 B8 mov qword ptr [r11-48h],rax +##00000000022D102D 48 B8 11 FF 00 00 00 00 FF FF mov rax,0FFFF00000000FF11h +# $code .= "\x49\x8D\x53\xB8";# lea rdx,[r11-48h] #arr param +##00000000022D103B 49 89 43 C0 mov qword ptr [r11-40h],rax +##00000000022D103F 48 B8 20 FF 00 00 00 00 FF FF mov rax,0FFFF00000000FF20h +##00000000022D1049 48 B9 02 00 00 FF FF 00 DE C0 mov rcx,0C0DE00FFFF000002h +# $code .= "\x48\xB9".PackedRVTarget($self);# mov rcx, the HV * +##00000000022D1053 49 89 43 C8 mov qword ptr [r11-38h],rax +##00000000022D1057 48 B8 21 FF 00 00 00 00 FF FF mov rax,0FFFF00000000FF21h +##00000000022D1061 49 89 43 D0 mov qword ptr [r11-30h],rax +##00000000022D1065 48 B8 30 FF 00 00 00 00 FF FF mov rax,0FFFF00000000FF30h +##00000000022D106F 49 89 43 D8 mov qword ptr [r11-28h],rax +##00000000022D1073 48 B8 31 FF 00 00 00 00 FF FF mov rax,0FFFF00000000FF31h +##00000000022D107D 49 89 43 E0 mov qword ptr [r11-20h],rax +##00000000022D1081 48 B8 40 FF 00 00 00 00 FF FF mov rax,0FFFF00000000FF40h +##00000000022D108B 49 89 43 E8 mov qword ptr [r11-18h],rax +##00000000022D108F 48 B8 41 FF 00 00 00 00 FF FF mov rax,0FFFF00000000FF41h +##00000000022D1099 49 89 43 F0 mov qword ptr [r11-10h],rax +##00000000022D109D 48 B8 01 00 00 FF FF 00 DE C0 mov rax,0C0DE00FFFF000001h +# $code .= "\x48\xB8".$Stage2FuncPtrPkd; # mov rax,0C0DE00FFFF000001h +# $code .= "\xFF\xD0";# call rax +## return *(void **)&retval; +# $code .= "\x48\x8B\x44\x24\x20";# mov rax,qword ptr [retval] +##} +# $code .= "\x48\x83\xC4\x78";# add rsp,78h +# $code .= "\xC3";# ret + +#$self->{codestr} = $code; #save memory +#32 bit perl doesn't use DEP in my testing, but use executable heap to be safe +#a Win32::API::Callback::HeapBlock is a ref to scalar, that scalar has the void * +my $ptr = ${($self->{codeExecAlloc} = Win32::API::Callback::HeapBlock->new(length($code)))}; +WriteMemory($ptr, $code, length($code)); +return $ptr; +} + + 1; __END__ @@ -161,17 +466,112 @@ Feedback is very appreciated. =item * Documentation is in the work. Either see the SYNOPSIS above -or the samples in the F<samples> directory. +or the samples in the F<samples> or the tests in the F<t> directory. =back +=head1 USAGE + +Win32::API::Callback uses a subset of the type letters of Win32::API. C Prototype +interface isn't supported. Not all the type letters of Win32::API are supported +in Win32::API::Callback. + +=over 4 + +=item C<I>: +value is an unsigned integer (unsigned int) + +=item C<i>: +value is an signed integer (signed int or int) + +=item C<N>: +value is a unsigned pointer sized number (unsigned long) + +=item C<n>: +value is a signed pointer sized number (signed long or long) + +=item C<Q>: +value is a unsigned 64 bit integer number (unsigned long long, unsigned __int64) +See next item for details. + +=item C<q>: +value is a signed 64 bit integer number (long long, __int64) +If your perl has 'Q'/'q' quads support for L<pack> then Win32::API's 'q' +is a normal perl numeric scalar. All 64 bit Perls have quad support. Almost no +32 bit Perls have quad support. On 32 bit Perls, without quad support, +Win32::API::Callback's 'q'/'Q' letter is a packed 8 byte string. +So C<0x8000000050000000> from a perl with native Quad support +would be written as C<"\x00\x00\x00\x50\x00\x00\x00\x80"> on a 32 bit +Perl without Quad support. To improve the use of 64 bit integers with +Win32::API::Callback on a 32 bit Perl without Quad support, there is +a per Win32::API::Callback object setting called L<Win32::API/UseMI64> +that causes all quads to be accepted as, and returned as L<Math::Int64> +objects. 4 to 8 byte long pass by copy/return type C aggregate types +are very rare in Windows, but they are supported as "in" and return +types by using 'q'/'Q' on 32 and 64 bits. Converting between the C aggregate +and its representation as a quad is up to the reader. For "out" in +Win32::API::Callback (not "in"), if the argument is a reference, it will +automatically be treated as a Math::Int64 object without having to +previously call this function. + +=item C<F>: +value is a floating point number (float) + +=item C<D>: +value is a double precision number (double) + +=item C<Unimplemented types>: +Unimplemented in Win32::API::Callback types such as shorts, chars, and +smaller than "machine word size" (32/64bit) numbers can be processed +by specifying N, then masking off the high bytes. +For example, to get a char, specify N, then do C<$numeric_char = $_[2] & 0xFF;> +in your Perl callback sub. To get a short, specify N, then do +C<$numeric_char = $_[2] & 0xFFFF;> in your Perl callback sub. + +=back + +=head2 FUNCTIONS + +=head3 new + + $CallbackObj = Win32::API::Callback->new( sub { print "hello world";}, + 'NDF', 'Q', '__cdecl'); + $CallbackObj = Win32::API::Callback->new( sub { print "hello world";}, + $in, $out); + +Creates and returns a new Win32::API::Callback object. Calling convention +parameter is optional. Calling convention parameter has same behaviour as +Win32::API's calling convention parameter. C prototype parsing of Win32::API +is not available with Win32::API::Callback. If the C caller assumes the +callback has vararg parameters, and the platform is 64 bits/x64, in the first 4 +parameters, if they are floats or doubles they will be garbage. Note there is +no way to create a Win32::API::Callback callback with a vararg prototype. +A workaround is to put "enough" Ns as the in types, and stop looking at the @_ +slices in your Perl sub callback after a certain count. Usually the first +parameter will somehow indicate how many additional stack parameters you are +receiving. The Ns in @_ will eventually become garbage, technically they are +the return address, saved registers, and C stack allocated variables of the +caller. They are effectivly garbage for your vararg callback. All vararg +callbacks on 32 bits must supply a calling convention, and it must be '__cdecl' +or 'WINAPIV'. + +=head2 METHODS + +=head3 UseMI64 + +See L<Win32::API/UseMI64>. + +=head1 SEE ALSO + +L<Win32::API::Callback::IATPatch> + =head1 AUTHOR Aldo Calpini ( I<dada@perl.it> ). +Daniel Dragan ( I<bulkdd@cpan.org> ). =head1 MAINTAINER Cosimo Streppone ( I<cosimo@cpan.org> ). =cut - |