KevinSchoenmayer/GseTDDUebungKCLR
2
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial Commit

Browse Source
This commit is contained in:
Riley Schneider
2025-12-03 16:38:10 +01:00
parent c5e26bf594
commit b732d8d4b5
17680 changed files with 5977495 additions and 2 deletions
Download Patch File Download Diff File Expand all files Collapse all files

575
database/perl/vendor/lib/Win32/API/Callback.pm vendored Normal file
View File

@@ -0,0 +1,575 @@
# See the bottom of this file for the POD documentation. Search for the
# string '=head'.
#######################################################################
#
# 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 $Stage2FuncPtrPkd );
$VERSION = '0.84';
#require XSLoader; # to dynuhlode the module. #already loaded by Win32::API
#use Data::Dumper;
use Win32::API qw ( WriteMemory ) ;
BEGIN {
#there is supposed to be 64 bit IVs on 32 bit perl compatibility here
#but it is untested
*IVSIZE = *Win32::API::IVSIZE;
#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]);}');
}
*DEBUGCONST = *Win32::API::DEBUGCONST;
*DEBUG = *Win32::API::DEBUG;
}
#######################################################################
# dynamically load in the API extension module.
#
XSLoader::load 'Win32::API::Callback', $VERSION;
#######################################################################
# PUBLIC METHODS
#
sub new {
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->{intypes} = []; #XS requires this, do not remove
if (ref($in) eq 'ARRAY') {
foreach (@$in) {
push(@{$self->{intypes}}, $_);
}
}
else {
my @in = split '', $in;
foreach (@in) {
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->{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" if DEBUGCONST;
my $hproc = MakeCB($self);
DEBUG "(PM)Callback::new: hproc=$hproc\n" if DEBUGCONST;
$self->{code} = $hproc;
#### cast the spell
return $self;
}
sub MakeStruct {
my ($self, $n, $addr) = @_;
DEBUG "(PM)Win32::API::Callback::MakeStruct: got self='$self'\n" if DEBUGCONST;
my $struct = Win32::API::Struct->new($self->{intypes}->[$n]);
$struct->FromMemory($addr);
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
."\xDD\xD8"# fstp st(0) pop a FP reg to make space on FPU stack
."\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__
#######################################################################
# DOCUMENTATION
#
=head1 NAME
Win32::API::Callback - Callback support for Win32::API
=head1 SYNOPSIS
use Win32::API;
use Win32::API::Callback;
my $callback = Win32::API::Callback->new(
sub { my($a, $b) = @_; return $a+$b; },
"NN", "N",
);
Win32::API->Import(
'mydll', 'two_integers_cb', 'KNN', 'N',
);
$sum = two_integers_cb( $callback, 3, 2 );
=head1 FOREWORDS
=over 4
=item *
Support for this module is B<highly experimental> at this point.
=item *
I won't be surprised if it doesn't work for you.
=item *
Feedback is very appreciated.
=item *
Documentation is in the work. Either see the SYNOPSIS above
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 KNOWN ISSUES
=over 4
=item *
Callback is safe across a Win32 psuedo-fork. Callback is not safe across a
Cygwin fork. On Cygwin, in the child process of the fork, a Segmentation Fault
will happen if the Win32::API::Callback callback is is called.
=back
=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

181
database/perl/vendor/lib/Win32/API/Callback/IATPatch.pod vendored Normal file
View File

@@ -0,0 +1,181 @@
=head1 NAME
Win32::API::Callback::IATPatch - Hooking and Patching a DLL's Imported C Functions
=head1 SYNOPSIS
use Win32::API;
use Win32::API::Callback;
warn "usually fatally errors on Cygwin" if $^O eq 'cygwin';
# do not do a "use" or "require" on Win32::API::Callback::IATPatch
# IATPatch comes with Win32::API::Callback
my $LoadLibraryExA;
my $callback = Win32::API::Callback->new(
sub {
my $libname = unpack('p', pack('J', $_[0]));
print "got $libname\n";
return $LoadLibraryExA->Call($libname, $_[1], $_[2]);
},
'NNI',
'N'
);
my $patch = Win32::API::Callback::IATPatch->new(
$callback, "perl518.dll", 'kernel32.dll', 'LoadLibraryExA');
die "failed to create IATPatch Obj $^E" if ! defined $patch;
$LoadLibraryExA = Win32::API::More->new( undef, $patch->GetOriginalFunctionPtr(), '
HMODULE
WINAPI
LoadLibraryExA(
LPCSTR lpLibFileName,
HANDLE hFile,
DWORD dwFlags
);
');
die "failed to make old function object" if ! defined $LoadLibraryExA;
require Encode;
#console will get a print of the dll filename now
=head1 DESCRIPTION
Win32::API::Callback::IATPatch allows you to hook a compile time dynamic linked
function call from any DLL (or EXE, from now on all examples are from a DLL to
another DLL, but from a EXE to a DLL is implied) in the Perl process, to a
different DLL in the same Perl process, by placing a Win32::API::Callback object
in between. This module does B<not> hook B<GetProcAddress> function calls. It
also will not hook a function call from a DLL to another function in the same
DLL. The function you want to hook B<must> appear in the B<import table> of the
DLL you want to use the hook. Functions from delay loaded DLL have their own
import table, it is different import table from the normal one IATPatch supports.
IATPatch will not find a delay loaded function and will not patch it. The hook
occurs at the caller DLL, not the callee DLL. This means your callback will be
called from all the calls to a one function in different DLL from the one
particular DLL the IATPatch object patched. The caller DLL is modified at
runtime, in the Perl process where the IATPatch was created, not on disk,
not globally among all processes. The callee or exporting DLL is NOT modified,
so your hook callback will be called from the 1 DLL that you choose to hook with
1 IATPatch object. You can create multiple IATPatch objects, one for each DLL in
the Perl process that you want to call your callback and not the original
destination function. If a new DLL is loaded into the process during runtime,
you must create a new IATPatch object specifically targeting it. There may be a
period from when the new DLL is loaded into the process, and when your Perl
script creates IATPatch object, where calls from that new DLL goto the real
destination function without hooking. If a DLL is unloaded, then reloaded into
the process, you must call C<Unpatch(0)> method on the old IATPatch object, then
create a new IATPatch object. IATPatch has no notification feature that a DLL
is being loaded or unloaded from the process. Unless you completely control, and
have the source code of the caller DLL, and understand all of the source code of
that DLL, there is a high chance that you will B<NOT> hook all calls from that
DLL to the destination function. If a call to the destination function is
dangerous or unacceptable, do not use IATPatch. IATPatch is not Microsoft
Detours or the like in any sense. Detours and its brethern will rewrite the
machine code in the beginning of the destination function call, hooking all
calls to that function call process wide, without exception.
Why this module was created? So I could mock kernel32 functions to
unit test Perl's C function calls to Kernel32.
=head2 CONSTRUCTORS
=head3 new
my $patch = Win32::API::Callback::IATPatch->new(
$A_Win32_API_Callback_Obj, $EXE_or_DLL_hmodule_or_name_to_hook,
$import_DLL_name, $import_function_name_or_ordinal);
Creates a new IATPatch object. The Win32::API::Callback will be called as long
as the IATPatch object exists. When an IATPatch object is DESTROYed, unless
C<-E<gt>Unpatch(0)> is called first, the patch is undone and the original
function is directly called from then on by that DLL. The DLL is not reference
count saved by an IATPatch object, so it may be unloaded at any time. If it is
unloaded you must call C<-E<gt>Unpatch(0)> before a DESTROY. Otherwise the DESTROY
will croak when it tries to unpatch the DLL. The DLL to hook must be a valid
PE file, while in memory. DLL and EXE "packers" can create invalid PE
files that do load successfully into memory, but they are not full PE files in
memory. On error, undef is returned and an error code is available through
L<Win32::GetLastError|Win32/Win32::GetLastError()>/L<perlvar/"$^E">. The error code may be from either
IATPatch directly, or from a Win32 call that IATPatch made. IATPatch objects
do not go through a L<perlfunc/"fork"> onto the child interp. IATPatch is fork safe.
The hook dll name can be one of 3 things, if the dllname is multiple things
(a number and a string), the first format found in the following order is used.
A string C<"123"> (a very strange DLL name BTW), this DLL is converted to DLL
HMODULE with GetModuleHandle. If there are 2 DLLs with the same filename,
refer to GetModuleHandle's
L<MSDN documentation|http://msdn.microsoft.com/en-us/library/windows/desktop/ms683199%28v=vs.85%29.aspx>
on what happens. Then if the
DLL name is an integer C<123456>, it is interpreted as a HMODULE directly.
If DLL name undefined, the file used to create the calling process will be
patched (a .exe). Finally if the DLL name is defined, a fatal error croak occurs.
It is best to use an HMODULE, since things like SxS can create multiple DLLs with
the same name in the same process. How to get an HMODULE, you are on your own.
C<$import_function_name_or_ordinal> can be one of 2 things. First it is checked if
it is a string, if so, it is used as the function name to hook. Else it is used
as an integer ordinal to hook. Importing by ordinal is obsolete in Windows, and
you shouldn't ever have to use it. The author of IATPatch was unable to test if
ordinal hooking works correctly in IATPatch.
=head2 METHODS
=head3 Unpatch
die "failed to undo the patch error: $^E" if !
$IATPatch->Unpatch(); #undo the patch
#or
die "failed to undo the patch error: $^E" if !
$IATPatch->Unpatch(1); #undo the patch
#or
die "failed to undo the patch error: $^E" if !
$IATPatch->Unpatch(0); #never undo the patch
#or
die "failed to undo the patch error: $^E" if !
$IATPatch->Unpatch(undef); #never undo the patch
Unpatches the DLL with the original destination function from the L<Win32::API::Callback::IATPatch/"new">
call. Returns undef on failure with error number available through
L<Win32::GetLastError|Win32/Win32::GetLastError()>/L<perlvar/"$^E">. If Unpatch was called once already,
calling it again will fail, and error will be ERROR_NO_MORE_ITEMS.
=head3 GetOriginalFunctionPtr
Returns the original function pointer found in the import table in C<123456>
format. If the returned pointer is 0, L<Win32::API::Callback::IATPatch/"Unpatch">
was called earlier. There are no error numbers associated with this method.
This value can be directly used to create a function pointer based Win32::API
object to call the original destination function from inside your Perl callback.
See L<Win32::API::Callback::IATPatch/"SYNOPSIS"> for a usage example.
=head1 BUGS AND LIMITATIONS
=over 4
=item E<nbsp>Cygwin not supported
L<new()|Win32::API::Callback::IATPatch/"new"> usually fatally errors on Cygwin
with "IATPatch 3GB mode not supported" on Cygwins that allocate the heap at
0x80000000 or are "Large Address Aware"
=back
=head1 SEE ALSO
L<Win32::API::Callback>
L<Win32::API>
L<http://msdn.microsoft.com/en-us/magazine/cc301808.aspx>
=head1 AUTHOR
Daniel Dragan ( I<bulkdd@cpan.org> ).
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2012 by Daniel Dragan
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.10.0 or,
at your option, any later version of Perl 5 you may have available.
=cut

755
database/perl/vendor/lib/Win32/API/Struct.pm vendored Normal file
View File

@@ -0,0 +1,755 @@
#
# Win32::API::Struct - Perl Win32 API struct Facility
#
# Author: Aldo Calpini <dada@perl.it>
# Maintainer: Cosimo Streppone <cosimo@cpan.org>
#
package Win32::API::Struct;
use strict;
use warnings;
use vars qw( $VERSION );
$VERSION = '0.67';
my %Known = ();
#import DEBUG sub
sub DEBUG;
*DEBUG = *Win32::API::DEBUG;
#package main;
#
#sub userlazyapisub2{
# userlazyapisub();
#}
#sub userlazyapisub {
# Win32::API::Struct::lazyapisub();
#}
#
#sub userapisub {
# Win32::API::Struct::apisub();
#}
#
#package Win32::API::Struct;
#
#sub lazyapisub {
# lazycarp('bad');
#}
#sub apisub {
# require Carp;
# Carp::carp('bad');
#}
sub lazycarp {
require Carp;
Carp::carp(@_);
}
sub lazycroak {
require Carp;
Carp::croak(@_);
}
sub typedef {
my $class = shift;
my $struct = shift;
my ($type, $name, @recog_arr);
my $self = {
align => undef,
typedef => [],
};
while (defined($type = shift)) {
#not compatible with "unsigned foo;"
$type .= ' '.shift if $type eq 'unsigned' || $type eq 'signed';
$name = shift;
#"int foo [8];" instead of "int foo[8];" so tack on the array count
{
BEGIN{warnings->unimport('uninitialized')}
$name .= shift if substr($_[0],0,1) eq '[';
}
#typedef() takes a list, not a str, for backcompat, this can't be changed
#but, should typedef() keep shifting slices until it finds ";" or not?
#all the POD examples have ;s, but they are actually optional, should it
#be assumed that existing code was nice and used ;s or not? backcompat
#breaks if you say ;-less member defs should be allowed and aren't a user
#mistake
$name =~ s/;$//;
@recog_arr = recognize($type, $name);
#http://perlmonks.org/?node_id=978468, not catching the type not found here,
#will lead to a div 0 later
if(@recog_arr != 3){
lazycarp "Win32::API::Struct::typedef: unknown member type=\"$type\", name=\"$name\"";
return undef;
}
push(@{$self->{typedef}}, [@recog_arr]);
}
$Known{$struct} = $self;
$Win32::API::Type::Known{$struct} = '>';
return 1;
}
#void ck_type($param, $proto, $param_num)
sub ck_type {
my ($param, $proto) = @_;
#legacy LP prefix check
return if substr($proto, 0, 2) eq 'LP' && substr($proto, 2) eq $param;
#check if proto can be converted to base struct name
return if exists $Win32::API::Struct::Pointer{$proto} &&
$param eq $Win32::API::Struct::Pointer{$proto};
#check if proto can have * chopped off to convert to base struct name
$proto =~ s/\s*\*$//;
return if $proto eq $param;
lazycroak("Win32::API::Call: supplied type (LP)\"".
$param."\"( *) doesn't match type \"".
$_[1]."\" for parameter ".
$_[2]." ");
}
#$basename = to_base_struct($pointername)
sub to_base_struct {
return $Win32::API::Struct::Pointer{$_[0]}
if exists $Win32::API::Struct::Pointer{$_[0]};
die "Win32::API::Struct::Unpack unknown type";
}
sub recognize {
my ($type, $name) = @_;
my ($size, $packing);
if (exists $Known{$type}) {
$packing = '>';
return ($name, $packing, $type);
}
else {
$packing = Win32::API::Type::packing($type);
return undef unless defined $packing;
if ($name =~ s/\[(.*)\]$//) {
$size = $1;
$packing = $packing . '*' . $size;
}
DEBUG "(PM)Struct::recognize got '$name', '$type' -> '$packing'\n" if DEBUGCONST;
return ($name, $packing, $type);
}
}
sub new {
my $class = shift;
my ($type, $name, $packing);
my $self = {typedef => [],};
if ($#_ == 0) {
if (is_known($_[0])) {
DEBUG "(PM)Struct::new: got '$_[0]'\n" if DEBUGCONST;
if( ! defined ($self->{typedef} = $Known{$_[0]}->{typedef})){
lazycarp 'Win32::API::Struct::new: unknown type="'.$_[0].'"';
return undef;
}
foreach my $member (@{$self->{typedef}}) {
($name, $packing, $type) = @$member;
next unless defined $name;
if ($packing eq '>') {
$self->{$name} = Win32::API::Struct->new($type);
}
}
$self->{__typedef__} = $_[0];
}
else {
lazycarp "Unknown Win32::API::Struct '$_[0]'";
return undef;
}
}
else {
while (defined($type = shift)) {
$name = shift;
# print "new: found member $name ($type)\n";
if (not exists $Win32::API::Type::Known{$type}) {
lazycarp "Unknown Win32::API::Struct type '$type'";
return undef;
}
else {
push(@{$self->{typedef}},
[$name, $Win32::API::Type::Known{$type}, $type]);
}
}
}
return bless $self;
}
sub members {
my $self = shift;
return map { $_->[0] } @{$self->{typedef}};
}
sub sizeof {
my $self = shift;
my $size = 0;
my $align = 0;
my $first = '';
for my $member (@{$self->{typedef}}) {
my ($name, $packing, $type) = @{$member};
next unless defined $name;
if (ref $self->{$name} eq q{Win32::API::Struct}) {
# If member is a struct, recursively calculate its size
# FIXME for subclasses
$size += $self->{$name}->sizeof();
}
else {
# Member is a simple type (LONG, DWORD, etc...)
if ($packing =~ /\w\*(\d+)/) { # Arrays (ex: 'c*260')
$size += Win32::API::Type::sizeof($type) * $1;
$first = Win32::API::Type::sizeof($type) * $1 unless defined $first;
DEBUG "(PM)Struct::sizeof: sizeof with member($name) now = " . $size
. "\n" if DEBUGCONST;
}
else { # Simple types
my $type_size = Win32::API::Type::sizeof($type);
$align = $type_size if $type_size > $align;
my $type_align = (($size + $type_size) % $type_size);
$size += $type_size + $type_align;
$first = Win32::API::Type::sizeof($type) unless defined $first;
}
}
}
my $struct_size = $size;
if (defined $align && $align > 0) {
$struct_size += ($size % $align);
}
DEBUG "(PM)Struct::sizeof first=$first totalsize=$struct_size\n" if DEBUGCONST;
return $struct_size;
}
sub align {
my $self = shift;
my $align = shift;
if (not defined $align) {
if (!(defined $self->{align} && $self->{align} eq 'auto')) {
return $self->{align};
}
$align = 0;
foreach my $member (@{$self->{typedef}}) {
my ($name, $packing, $type) = @$member;
if (ref($self->{$name}) eq "Win32::API::Struct") {
#### ????
}
else {
if ($packing =~ /\w\*(\d+)/) {
#### ????
}
else {
$align = Win32::API::Type::sizeof($type)
if Win32::API::Type::sizeof($type) > $align;
}
}
}
return $align;
}
else {
$self->{align} = $align;
}
}
sub getPack {
my $self = shift;
my $packing = "";
my $packed_size = 0;
my ($type, $name, $type_size, $type_align);
my @items = ();
my @recipients = ();
my @buffer_ptrs = (); #this contains the struct_ptrs that were placed in the
#the struct, its part of "C func changes the struct ptr to a private allocated
#struct" code, it is push/poped only for struct ptrs, it is NOT a 1 to
#1 mapping between all struct members, so don't access it with indexes
my $align = $self->align();
foreach my $member (@{$self->{typedef}}) {
my ($name, $type, $orig) = @$member;
if ($type eq '>') {
my ($subpacking, $subitems, $subrecipients, $subpacksize, $subbuffersptrs) =
$self->{$name}->getPack();
DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $subpacking\n" if DEBUGCONST;
push(@items, @$subitems);
push(@recipients, @$subrecipients);
push(@buffer_ptrs, @$subbuffersptrs);
$packing .= $subpacking;
$packed_size += $subpacksize;
}
else {
my $repeat = 1;
$type_size = Win32::API::Type::sizeof($orig);
if ($type =~ /\w\*(\d+)/) {
$repeat = $1;
$type = 'a'.($repeat*$type_size);
}
DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $type\n" if DEBUGCONST;
if ($type eq 'p') {
$type = Win32::API::Type::pointer_pack_type();
push(@items, Win32::API::PointerTo($self->{$name}));
}
elsif ($type eq 'T') {
$type = Win32::API::Type::pointer_pack_type();
my $structptr;
if(ref($self->{$name})){
$self->{$name}->Pack();
$structptr = Win32::API::PointerTo($self->{$name}->{buffer});
}
else{
$structptr = 0;
}
push(@items, $structptr);
push(@buffer_ptrs, $structptr);
}
else {
push(@items, $self->{$name});
}
push(@recipients, $self);
$type_align = (($packed_size + $type_size) % $type_size);
$packing .= "x" x $type_align . $type;
$packed_size += ( $type_size * $repeat ) + $type_align;
}
}
DEBUG
"(PM)Struct::getPack: $self->{__typedef__}(buffer) = pack($packing, $packed_size)\n" if DEBUGCONST;
return ($packing, [@items], [@recipients], $packed_size, \@buffer_ptrs);
}
# void $struct->Pack([$priv_warnings_flag]);
sub Pack {
my $self = shift;
my ($packing, $items);
($packing, $items, $self->{buffer_recipients},
undef, $self->{buffer_ptrs}) = $self->getPack();
DEBUG "(PM)Struct::Pack: $self->{__typedef__}(buffer) = pack($packing, @$items)\n" if DEBUGCONST;
if($_[0]){ #Pack() on a new struct, without slice set, will cause lots of uninit
#warnings, sometimes its intentional to set up buffer recipients for a
#future UnPack()
BEGIN{warnings->unimport('uninitialized')}
$self->{buffer} = pack($packing, @$items);
}
else{
$self->{buffer} = pack($packing, @$items);
}
if (DEBUGCONST) {
for my $i (0 .. $self->sizeof - 1) {
printf "#pack# %3d: 0x%02x\n", $i, ord(substr($self->{buffer}, $i, 1));
}
}
}
sub getUnpack {
my $self = shift;
my $packing = "";
my $packed_size = 0;
my ($type, $name, $type_size, $type_align, $orig_type);
my (@items, @types, @type_names);
my $align = $self->align();
foreach my $member (@{$self->{typedef}}) {
my ($name, $type, $orig) = @$member;
if ($type eq '>') {
my ($subpacking, $subpacksize, $subitems, $subtypes, $subtype_names) = $self->{$name}->getUnpack();
DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $subpacking\n" if DEBUGCONST;
$packing .= $subpacking;
$packed_size += $subpacksize;
push(@items, @$subitems);
push(@types, @$subtypes);
push(@type_names, @$subtype_names);
}
else {
if($type eq 'T') {
$orig_type = $type;
$type = Win32::API::Type::pointer_pack_type();
}
$type_size = Win32::API::Type::sizeof($orig);
my $repeat = 1;
if ($type =~ /\w\*(\d+)/) { #some kind of array
$repeat = $1;
$type =
$type_size == 1 ?
'Z'.$repeat #have pack truncate to NULL char
:'a'.($repeat*$type_size); #manually truncate to wide NULL char later
}
DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $type\n" if DEBUGCONST;
$type_align = (($packed_size + $type_size) % $type_size);
$packing .= "x" x $type_align . $type;
$packed_size += ( $type_size * $repeat ) + $type_align;
push(@items, $name);
if($orig_type){
push(@types, $orig_type);
undef($orig_type);
}
else{
push(@types, $type);
}
push(@type_names, $orig);
}
}
DEBUG "(PM)Struct::getUnpack($self->{__typedef__}): unpack($packing, @items)\n" if DEBUGCONST;
return ($packing, $packed_size, \@items, \@types, \@type_names);
}
sub Unpack {
my $self = shift;
my ($packing, undef, $items, $types, $type_names) = $self->getUnpack();
my @itemvalue = unpack($packing, $self->{buffer});
DEBUG "(PM)Struct::Unpack: unpack($packing, buffer) = @itemvalue\n" if DEBUGCONST;
foreach my $i (0 .. $#$items) {
my $recipient = $self->{buffer_recipients}->[$i];
my $item = $$items[$i];
my $type = $$types[$i];
DEBUG "(PM)Struct::Unpack: %s(%s) = '%s' (0x%08x)\n",
$recipient->{__typedef__},
$item,
$itemvalue[$i],
$itemvalue[$i],
if DEBUGCONST;
if($type eq 'T'){
my $oldstructptr = pop(@{$self->{buffer_ptrs}});
my $newstructptr = $itemvalue[$i];
my $SVMemberRef = \$recipient->{$item};
if(!$newstructptr){ #new ptr is null
if($oldstructptr != $newstructptr){ #old ptr was true
lazycarp "Win32::API::Struct::Unpack struct pointer".
" member \"".$item."\" was changed by C function,".
" possible resource leak";
}
$$SVMemberRef = undef;
}
else{ #new ptr is true
if($oldstructptr != $newstructptr){#old ptr was true, or null, but has changed, leak warning
lazycarp "Win32::API::Struct::Unpack struct pointer".
" member \"".$item."\" was changed by C function,".
" possible resource leak";
}#create a ::Struct if the slice is undef, user had the slice set to undef
if (!ref($$SVMemberRef)){
$$SVMemberRef = Win32::API::Struct->new(to_base_struct($type_names->[$i]));
$$SVMemberRef->Pack(1); #buffer_recipients must be generated, no uninit warnings
}
#must fix {buffer} with contents of the new struct, $structptr might be
#null or might be a SVPV from a ::Struct that was ignored, in any case,
#a foreign memory allocator is at work here
$$SVMemberRef->{buffer} = Win32::API::ReadMemory($newstructptr, $$SVMemberRef->sizeof)
if($oldstructptr != $newstructptr);
#always must be called, if new ptr is not null, at this point, C func, did
#one of 2 things, filled the old ::Struct's {buffer} PV, or gave a new struct *
#from its own allocator, there is no way to tell if the struct contents changed
#so Unpack() must be called
$$SVMemberRef->Unpack();
}
}
else{ #not a struct ptr
my $itemvalueref = \$itemvalue[$i];
Win32::API::_TruncateToWideNull($$itemvalueref)
if substr($type,0,1) eq 'a' && length($type) > 1;
$recipient->{$item} = $$itemvalueref;
# DEBUG "(PM)Struct::Unpack: self.items[$i] = $self->{$$items[$i]}\n";
}
}
}
sub FromMemory {
my ($self, $addr) = @_;
DEBUG "(PM)Struct::FromMemory: doing Pack\n" if DEBUGCONST;
$self->Pack();
DEBUG "(PM)Struct::FromMemory: doing GetMemory( 0x%08x, %d )\n", $addr, $self->sizeof if DEBUGCONST;
$self->{buffer} = Win32::API::ReadMemory($addr, $self->sizeof);
$self->Unpack();
if(DEBUGCONST) {
DEBUG "(PM)Struct::FromMemory: doing Unpack\n";
DEBUG "(PM)Struct::FromMemory: structure is now:\n";
$self->Dump();
DEBUG "\n";
}
}
sub Dump {
my $self = shift;
my $prefix = shift;
foreach my $member (@{$self->{typedef}}) {
my ($name, $packing, $type) = @$member;
if (ref($self->{$name})) {
$self->{$name}->Dump($name);
}
else {
printf "%-20s %-20s %-20s\n", $prefix, $name, $self->{$name};
}
}
}
#the LP logic should be moved to parse_prototype, since only
#::API::Call() ever understood the implied LP prefix, Struct::new never did
#is_known then can be inlined away and sub deleted, it is not public API
sub is_known {
my $name = shift;
if (exists $Known{$name}) {
return 1;
}
else {
my $nametest = $name;
if ($nametest =~ s/^LP//) {
return exists $Known{$nametest};
}
$nametest = $name;
if($nametest =~ s/\*$//){
return exists $Known{$nametest};
}
return 0;
}
}
sub TIEHASH {
return Win32::API::Struct::new(@_);
}
sub EXISTS {
}
sub FETCH {
my $self = shift;
my $key = shift;
if ($key eq 'sizeof') {
return $self->sizeof;
}
my @members = map { $_->[0] } @{$self->{typedef}};
if (grep(/^\Q$key\E$/, @members)) {
return $self->{$key};
}
else {
warn "'$key' is not a member of Win32::API::Struct $self->{__typedef__}";
}
}
sub STORE {
my $self = shift;
my ($key, $val) = @_;
my @members = map { $_->[0] } @{$self->{typedef}};
if (grep(/^\Q$key\E$/, @members)) {
$self->{$key} = $val;
}
else {
warn "'$key' is not a member of Win32::API::Struct $self->{__typedef__}";
}
}
sub FIRSTKEY {
my $self = shift;
my @members = map { $_->[0] } @{$self->{typedef}};
return $members[0];
}
sub NEXTKEY {
my $self = shift;
my $key = shift;
my @members = map { $_->[0] } @{$self->{typedef}};
for my $i (0 .. $#members - 1) {
return $members[$i + 1] if $members[$i] eq $key;
}
return undef;
}
1;
__END__
#######################################################################
# DOCUMENTATION
#
=head1 NAME
Win32::API::Struct - C struct support package for Win32::API
=head1 SYNOPSIS
use Win32::API;
Win32::API::Struct->typedef( 'POINT', qw(
LONG x;
LONG y;
));
my $Point = Win32::API::Struct->new( 'POINT' );
$Point->{x} = 1024;
$Point->{y} = 768;
#### alternatively
tie %Point, 'Win32::API::Struct', 'POINT';
$Point{x} = 1024;
$Point{y} = 768;
=head1 ABSTRACT
This module enables you to define C structs for use with
Win32::API.
See L<Win32::API/USING STRUCTURES> for more info about its usage.
=head1 DESCRIPTION
This module is automatically imported by Win32::API, so you don't
need to 'use' it explicitly. The main methods are C<typedef> and
C<new>, which are documented below.
=over 4
=item C<typedef NAME, TYPE, MEMBER, TYPE, MEMBER, ...>
This method defines a structure named C<NAME>. The definition consists
of types and member names, just like in C. In fact, most of the
times you can cut the C definition for a structure and paste it
verbatim to your script, enclosing it in a C<qw()> block. The
function takes care of removing the semicolon after the member
name. Win32::API::Struct does B<NOT> support Enums, Unions, or Bitfields.
C<NAME> must not end in C<*>, typedef creates structs, not struct pointers.
See L<Win32::API::Type/"typedef">
on how to create a struct pointer type. Returns true on success, and undef on error.
On error it L<warns|perlfunc/warn> with the specific reason.
The synopsis example could be written like this:
Win32::API::Struct->typedef('POINT', 'LONG', 'x', 'LONG', 'y');
But it could also be written like this (note the indirect object
syntax), which is pretty cool:
typedef Win32::API::Struct POINT => qw{
LONG x;
LONG y;
};
L<Win32::API/Call> automatically knows that an 'LPNAME' type, refers
to a 'NAME' type struct. Also see L<Win32::API::Type/"typedef"> on how to declare
pointers to struct types.
Unlike in Win32::API, a single non-array char or CHAR struct member in a
struct is numeric, NOT the first character of a string. UTF16 strings pointers
will be garbage on read back (passing in works, returning doesn't) since
the NULL character will often be the 2nd byte of the UTF16 string.
=item C<new NAME>
This creates a structure (a Win32::API::Struct object) of the
type C<NAME> (it must have been defined with C<typedef>). In Perl,
when you create a structure, all the members are undefined. But
when you use that structure in C (eg. a Win32::API call), you
can safely assume that they will be treated as zero (or NULL).
=item C<sizeof>
This returns the size, in bytes, of the structure. Acts just like
the C function of the same name. It is particularly useful for
structures that need a member to be initialized to the structure's
own size.
=item C<align [SIZE]>
Sets or returns the structure alignment (eg. how the structure is
stored in memory). This is a very advanced option, and you normally
don't need to mess with it.
All structures in the Win32 Platform SDK should work without it.
But if you define your own structure, you may need to give it an
explicit alignment. In most cases, passing a C<SIZE> of 'auto'
should keep the world happy.
=back
=head2 THE C<tie> INTERFACE
Instead of creating an object with the C<new> method, you can
tie a hash, which will hold the desired structure, using the
C<tie> builtin function:
tie %structure, Win32::API::Struct => 'NAME';
The differences between the tied and non-tied approaches are:
=over 4
=item *
with tied structures, you can access members directly as
hash lookups, eg.
# tied # non-tied
$Point{x} vs. $Point->{x}
=item *
with tied structures, when you try to fetch or store a
member that is not part of the structure, it will result
in a warning, eg.
print $Point{z};
# this will warn: 'z' is not a member of Win32::API::Struct POINT
=item *
when you pass a tied structure as a Win32::API parameter,
remember to backslash it, eg.
# tied # non-tied
GetCursorPos( \%Point ) vs. GetCursorPos( $Point )
=back
=head2 FOREIGN MEMORY ALLOCATORS
Using Win32::API::Struct is not recommended in situations where a C function
will return results to you by putting a pointer to a string or a pointer to
another struct into your supplied struct. Win32::API::Struct will do its best
to detect that a new pointer appeared and to read it contents into Perl, but
that pointer will be tossed away after being read. If this pointer is
something you must explicitly free, you have leaked it by using
Win32::API::Struct to decode it. If this pointer is something you must pass back to
the C API you are using, you lost/leaked it. If you pass NULL, or a ::Struct
pointer in a ::Struct to C API, after the C API call, ::Struct will detect the
pointer changed, it will read the new struct from the new pointer into
Perl, and a new child ::Struct will appear in the hash slice
of the parent ::Struct, if you pass this new child ::Struct into the C API
it will be a B<COPY> of the struct the C API from Perl's allocation placed
in the parent ::Struct. For C++-like APIs, this will be unacceptable and lead to
crashes as the C Functions tries to free a memory block that didn't come from the
allocator of the C Function. Windows has many memory allocators, each CRT
(VS 2, 3, 4, 5, NT/6, 7.0, 7.1, 8, 9, 10) malloc, LocalAlloc, GlobalAlloc,
HeapAlloc, (each version of C++ Runtime Library) "new", CoGetMalloc, CoTaskMemAlloc,
NetApiBufferAllocate, VirtualAlloc, CryptMemAlloc, AllocADsMem, SHAlloc,
SnmpUtilMemAlloc. None of these allocators' pointers are compatible with Perl's
allocator. Some C APIs give you static global buffers which never are freed or freed
automatically in the next call to a function from to that DLL.
With foreign allocators, its best to treat to write a pointer class, bless the
ref to scalar integer (holding the pointer) into that class to ensure that the
DESTROY method will free the pointer and you never leak it, and your write
method accessors using L<perlfunc/pack>, L<Win32::API/ReadMemory> and
L<Win32::API/WriteMemory> around the pointer.
=head1 AUTHOR
Aldo Calpini ( I<dada@perl.it> ).
=head1 MAINTAINER
Cosimo Streppone ( I<cosimo@cpan.org> ).
=cut

590
database/perl/vendor/lib/Win32/API/Type.pm vendored Normal file
View File

@@ -0,0 +1,590 @@
package Win32::API::Type;
# See the bottom of this file for the POD documentation. Search for the
# string '=head'.
#######################################################################
#
# Win32::API::Type - Perl Win32 API type definitions
#
# Author: Aldo Calpini <dada@perl.it>
# Maintainer: Cosimo Streppone <cosimo@cpan.org>
#
#######################################################################
use strict;
use warnings;
use vars qw( %Known %PackSize %Modifier %Pointer $VERSION );
$VERSION = '0.70';
#import DEBUG sub
sub DEBUG;
*DEBUG = *Win32::API::DEBUG;
#const optimize
BEGIN {
eval ' sub pointer_pack_type () { \''
.(PTRSIZE == 8 ? 'Q' : 'L').
'\' }';
}
%Known = ();
%PackSize = ();
%Modifier = ();
%Pointer = ();
# Initialize data structures at startup.
# Aldo wants to keep the <DATA> approach.
#
my $section = 'nothing';
foreach (<DATA>) {
next if /^\s*(?:#|$)/;
chomp;
if (/\[(.+)\]/) {
$section = $1;
next;
}
if ($section eq 'TYPE') {
my ($name, $packing) = split(/\s+/);
# DEBUG "(PM)Type::INIT: Known('$name') => '$packing'\n";
$packing = pointer_pack_type()
if ($packing eq '_P');
$Known{$name} = $packing;
}
elsif ($section eq 'POINTER') {
my ($pointer, $pointto) = split(/\s+/);
# DEBUG "(PM)Type::INIT: Pointer('$pointer') => '$pointto'\n";
$Pointer{$pointer} = $pointto;
}
elsif ($section eq 'PACKSIZE') {
my ($packing, $size) = split(/\s+/);
# DEBUG "(PM)Type::INIT: PackSize('$packing') => '$size'\n";
$size = PTRSIZE
if ($size eq '_P');
$PackSize{$packing} = $size;
}
elsif ($section eq 'MODIFIER') {
my ($modifier, $mapto) = split(/\s+/, $_, 2);
my %maps = ();
foreach my $item (split(/\s+/, $mapto)) {
my ($k, $v) = split(/=/, $item);
$maps{$k} = $v;
}
# DEBUG "(PM)Type::INIT: Modifier('$modifier') => '%maps'\n";
$Modifier{$modifier} = {%maps};
}
}
close(DATA);
sub new {
my $class = shift;
my ($type) = @_;
my $packing = packing($type);
my $size = sizeof($type);
my $self = {
type => $type,
packing => $packing,
size => $size,
};
return bless $self;
}
sub typedef {
my $class = shift;
my ($name, $type) = @_;
$type =~ m/^\s*(.*?)\s*$/;
$type =~ m/^(.+?)\s*(\*)$/;
$type = $1;
$type .= $2 if defined $2;
$name =~ m/^\s*(.*?)\s*$/;
$name =~ m/^(.+?)\s*(\*)$/;
$name = $1;
$name .= $2 if defined $2;
#FIXME BUG, unsigned __int64 * doesn't pase in typedef, it does in parse_prototype
my $packing = packing($type, $name); #FIXME BUG
if(! defined $packing){
warn "Win32::API::Type::typedef: WARNING unknown type '$_[1]'";
return undef;
}
#Win32::API::Struct logic
#limitation, this won't alias a new struct type to an existing struct type
#this only creates new struct type pointer types to an existing struct type
if($packing eq '>'){
if(is_pointer($type)){
$packing = 'T';
$type =~ s/\s*\*$//; #chop off ' *'
$Win32::API::Struct::Pointer{$name} = $type;
}
else{
warn "Win32::API::Type::typedef: aliasing struct \"".$_[0]
."\" to struct \"".$_[1]."\" not supported";
return undef;
}
}
DEBUG "(PM)Type::typedef: packing='$packing'\n" if DEBUGCONST;
if($packing eq 'p'){
$Pointer{$name} = $Pointer{$type};
}else{
$Known{$name} = $packing;
}
return 1;
}
sub is_known {
my $self = shift;
my $type = shift;
$type = $self unless defined $type;
if (ref($type) =~ /Win32::API::Type/) {
return 1;
}
else {
return defined packing($type);
}
}
sub sizeof {
my $self = shift;
my $type = shift;
$type = $self unless defined $type;
if (ref($type) =~ /Win32::API::Type/) {
return $self->{size};
}
else {
my $packing = packing($type);
if ($packing =~ /(\w)\*(\d+)/) {
return $PackSize{$1} * $2;
}
else {
return $PackSize{$packing};
}
}
}
# $packing_letter = packing( [$class = 'Win32::API::Type' ,] $type [, $pass_numeric])
sub packing {
# DEBUG "(PM)Type::packing: called by ". join("::", (caller(1))[0,3]). "\n";
my $self = shift;
my $is_pointer = 0;
if (ref($self) =~ /Win32::API::Type/) {
# DEBUG "(PM)Type::packing: got an object\n";
return $self->{packing};
}
my $type = ($self eq 'Win32::API::Type') ? shift : $self;
my $name = shift;
my $pass_numeric = shift;
# DEBUG "(PM)Type::packing: got '$type', '$name'\n";
my ($modifier, $size, $packing);
if (exists $Pointer{$type}) {
# DEBUG "(PM)Type::packing: got '$type', is really '$Pointer{$type}'\n";
$type = $Pointer{$type};
$is_pointer = 1;
}
elsif ($type =~ /(\w+)\s+(\w+)/) {
$modifier = $1;
$type = $2;
# DEBUG "(PM)packing: got modifier '$modifier', type '$type'\n";
}
$type =~ s/\s*\*$//; #kill whitespace "CHAR " isn't "CHAR"
if (exists $Known{$type}) {
if (defined $name and $name =~ s/\[(.*)\]$//) {
$size = $1;
$packing = $Known{$type}[0] . "*" . $size;
# DEBUG "(PM)Type::packing: composite packing: '$packing' '$size'\n";
}
else {
$packing = $Known{$type};
if ($is_pointer and ($packing eq 'c' or $packing eq 'S')) {
$packing = "p";
}
# DEBUG "(PM)Type::packing: simple packing: '$packing'\n";
}
if (defined $modifier and exists $Modifier{$modifier}->{$type}) {
# DEBUG "(PM)Type::packing: applying modifier '$modifier' -> '$Modifier{$modifier}->{$type}'\n";
$packing = $Modifier{$modifier}->{$type};
if(!$pass_numeric) { #for older num unaware calls
substr($packing, 0, length("num"), '');
}
}
return $packing;
}
else {
# DEBUG "(PM)Type::packing: NOT FOUND\n";
return undef;
}
}
sub is_pointer {
my $self = shift;
my $type = shift;
$type = $self unless defined $type;
if (ref($type) =~ /Win32::API::Type/) {
return 1;
}
else {
if ($type =~ /\*$/) {
return 1;
}
else {
return exists $Pointer{$type};
}
}
}
sub Pack {
my $type = $_[1];
my $pack_type = packing($type);
#print "Pack: type $type pack_type $pack_type\n";
if ($pack_type eq 'p') { #char or wide char pointer
#$pack_type = 'Z*';
return;
}
elsif(IVSIZE() == 4 && ($pack_type eq 'q' || $pack_type eq 'Q')){
if($_[0]->UseMI64() || ref($_[2])){ #un/signed meaningless
$_[2] = Math::Int64::int64_to_native($_[2]);
}
else{
if(length($_[2]) < 8){
warn("Win32::API::Call value for 64 bit integer is under 8 bytes long");
$_[2] = pack('a8', $_[2]);
}
}
return;
}
$_[2] = pack($pack_type, $_[2]);
return;
}
sub Unpack {
my $type = $_[1];
my $pack_type = packing($type);
if ($pack_type eq 'p') {
DEBUG "(PM)Type::Unpack: got packing 'p': is a pointer\n" if DEBUGCONST;
#$pack_type = 'Z*';
return;
}
elsif(IVSIZE() == 4){
#todo debugging output
if($pack_type eq 'q'){
if($_[0]->UseMI64() || ref($_[2])){
$_[2] = Math::Int64::native_to_int64($_[2]);
DEBUG "(PM)Type::Unpack: returning signed Math::Int64 '".$_[2]."'\n" if DEBUGCONST;
}
return;
}elsif($pack_type eq 'Q'){
if($_[0]->UseMI64() || ref($_[2])){
$_[2] = Math::Int64::native_to_uint64($_[2]);
DEBUG "(PM)Type::Unpack: returning unsigned Math::Int64 '".$_[2]."'\n" if DEBUGCONST;
}
return;
}
}
DEBUG "(PM)Type::Unpack: unpacking '$pack_type' '$_[2]'\n" if DEBUGCONST;
$_[2] = unpack($pack_type, $_[2]);
DEBUG "(PM)Type::Unpack: returning '" . ($_[2] || '') . "'\n" if DEBUGCONST;
}
1;
#######################################################################
# DOCUMENTATION
#
=head1 NAME
Win32::API::Type - C type support package for Win32::API
=head1 SYNOPSIS
use Win32::API;
Win32::API::Type->typedef( 'my_number', 'LONG' );
=head1 ABSTRACT
This module is a support package for Win32::API that implements
C types for the import with prototype functionality.
See L<Win32::API> for more info about its usage.
=head1 DESCRIPTION
This module is automatically imported by Win32::API, so you don't
need to 'use' it explicitly. These are the methods of this package:
=over 4
=item C<typedef NAME, TYPE>
This method defines a new type named C<NAME>. This actually just
creates an alias for the already-defined type C<TYPE>, which you
can use as a parameter in a Win32::API call.
When C<TYPE> contains a Win32::API::Struct type declared with
L<Win32::API::Struct/typedef> with " *" postfixed to C<TYPE> parameter,
C<NAME> will be a alias for the pointer version of the struct type. Creating
an alias for a struct type is not supported, you have to call
L<Win32::API::Struct/typedef> again. Passing a struct type as C<TYPE>
without the " *" postfix is not supported.
L<Warns|perlfunc/warn> and returns undef if C<TYPE> is unknown, else returns true.
=item C<sizeof TYPE>
This returns the size, in bytes, of C<TYPE>. Acts just like
the C function of the same name.
=item C<is_known TYPE>
Returns true if C<TYPE> is known by Win32::API::Type, false
otherwise.
=back
=head2 SUPPORTED TYPES
This module recognizes many commonly used types defined in the Win32 Platform
SDK header files, but not all. Types less than 13 years old are very unlikely
to be the in built type database.
Please see the source for this module, in the C<__DATA__> section,
for the full list of builtin supported types.
=head2 NOTES ON SELECT TYPES
=over 4
=item LPVOID
Due to poor design, currently LPVOID is a char *, a string, not a number.
It should really be a number. It is suggested to replace LPVOID in your
C prototypes passed to Win32::API with UINT_PTR which is a pointer
sized number.
=item SOMETYPE **
Currently ** types do not parse.
=item void **
Replace void ** in your C prototype that you pass to Win32::API::More with
LPHANDLE.
=item unsigned char
=item signed char
These 2 types by name force numeric handling. C<97> not C<"a">. C<UCHAR> is
not a C<unsigned char> for numeric handling purposes.
=back
=head1 AUTHOR
Aldo Calpini ( I<dada@perl.it> ).
=head1 MAINTAINER
Cosimo Streppone ( I<cosimo@cpan.org> ).
=cut
__DATA__
[TYPE]
ATOM s
BOOL L
BOOLEAN c
BYTE C
CHAR c
COLORREF L
DWORD L
DWORD32 L
DWORD64 Q
DWORD_PTR _P
FLOAT f
HACCEL _P
HANDLE _P
HBITMAP _P
HBRUSH _P
HCOLORSPACE _P
HCONV _P
HCONVLIST _P
HCURSOR _P
HDC _P
HDDEDATA _P
HDESK _P
HDROP _P
HDWP _P
HENHMETAFILE _P
HFILE _P
HFONT _P
HGDIOBJ _P
HGLOBAL _P
HHOOK _P
HICON _P
HIMC _P
HINSTANCE _P
HKEY _P
HKL _P
HLOCAL _P
HMENU _P
HMETAFILE _P
HMODULE _P
HPALETTE _P
HPEN _P
HRGN _P
HRSRC _P
HSZ _P
HWINSTA _P
HWND _P
INT i
INT32 i
INT64 q
LANGID s
LCID L
LCSCSTYPE L
LCSGAMUTMATCH L
LCTYPE L
LONG l
LONG32 l
LONG64 q
LONGLONG q
LPARAM _P
LRESULT _P
NTSTATUS l
REGSAM L
SC_HANDLE _P
SC_LOCK _P
SERVICE_STATUS_HANDLE _P
SHORT s
SIZE_T _P
SSIZE_T _P
TBYTE c
TCHAR C
UCHAR C
UINT I
UINT_PTR _P
UINT32 I
UINT64 Q
ULONG L
ULONG32 L
ULONG64 Q
ULONGLONG Q
USHORT S
WCHAR S
WORD S
WPARAM _P
VOID c
int i
long l
float f
double d
char c
short s
void c
__int64 q
#VOID is a 'c'? huh?
#making void be a 'c' too, ~bulk88
#CRITICAL_SECTION 24 -- a structure
#LUID ? 8 -- a structure
#VOID 0
#CONST 4
#FILE_SEGMENT_ELEMENT 8 -- a structure
[PACKSIZE]
c 1
C 1
d 8
f 4
i 4
I 4
l 4
L 4
q 8
Q 8
s 2
S 2
p _P
T _P
t _P
[MODIFIER]
unsigned int=numI long=numL short=numS char=numC
signed int=numi long=numl short=nums char=numc
[POINTER]
INT_PTR INT
LPBOOL BOOL
LPBYTE BYTE
LPCOLORREF COLORREF
LPCSTR CHAR
#LPCTSTR CHAR or WCHAR
LPCTSTR CHAR
LPCVOID any
LPCWSTR WCHAR
LPDOUBLE double
LPDWORD DWORD
LPHANDLE HANDLE
LPINT INT
LPLONG LONG
LPSTR CHAR
#LPTSTR CHAR or WCHAR
LPTSTR CHAR
LPVOID VOID
LPWORD WORD
LPWSTR WCHAR
PBOOL BOOL
PBOOLEAN BOOL
PBYTE BYTE
PCHAR CHAR
PCSTR CSTR
PCWCH CWCH
PCWSTR CWSTR
PDWORD DWORD
PFLOAT FLOAT
PHANDLE HANDLE
PHKEY HKEY
PINT INT
PLCID LCID
PLONG LONG
PSHORT SHORT
PSTR CHAR
#PTBYTE TBYTE --
#PTCHAR TCHAR --
#PTSTR CHAR or WCHAR
PTSTR CHAR
PUCHAR UCHAR
PUINT UINT
PULONG ULONG
PUSHORT USHORT
PVOID VOID
PWCHAR WCHAR
PWORD WORD
PWSTR WCHAR
char* CHAR