diff options
author | Karl Berry <karl@freefriends.org> | 2016-04-05 22:27:26 +0000 |
---|---|---|
committer | Karl Berry <karl@freefriends.org> | 2016-04-05 22:27:26 +0000 |
commit | b56b320b5e2515160073fa1b469514002688fe11 (patch) | |
tree | 965a7100c5e45fca8ec803d22b8b6ce14fca4633 /Master/tlpkg/tlperl/site/lib/Win32/API | |
parent | d26c206452d2e285c3bbf949f34011e4a55fd8f9 (diff) |
tlperl 5.22.1 from siep
git-svn-id: svn://tug.org/texlive/trunk@40252 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/site/lib/Win32/API')
-rw-r--r-- | Master/tlpkg/tlperl/site/lib/Win32/API/Callback.pm | 575 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/site/lib/Win32/API/Callback/IATPatch.pod | 181 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/site/lib/Win32/API/Struct.pm | 755 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/site/lib/Win32/API/Type.pm | 590 |
4 files changed, 2101 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/site/lib/Win32/API/Callback.pm b/Master/tlpkg/tlperl/site/lib/Win32/API/Callback.pm new file mode 100644 index 00000000000..1731a637fb0 --- /dev/null +++ b/Master/tlpkg/tlperl/site/lib/Win32/API/Callback.pm @@ -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 diff --git a/Master/tlpkg/tlperl/site/lib/Win32/API/Callback/IATPatch.pod b/Master/tlpkg/tlperl/site/lib/Win32/API/Callback/IATPatch.pod new file mode 100644 index 00000000000..27eb1af2fb6 --- /dev/null +++ b/Master/tlpkg/tlperl/site/lib/Win32/API/Callback/IATPatch.pod @@ -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 diff --git a/Master/tlpkg/tlperl/site/lib/Win32/API/Struct.pm b/Master/tlpkg/tlperl/site/lib/Win32/API/Struct.pm new file mode 100644 index 00000000000..85d1f7154d4 --- /dev/null +++ b/Master/tlpkg/tlperl/site/lib/Win32/API/Struct.pm @@ -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 diff --git a/Master/tlpkg/tlperl/site/lib/Win32/API/Type.pm b/Master/tlpkg/tlperl/site/lib/Win32/API/Type.pm new file mode 100644 index 00000000000..3c4c4d5feaf --- /dev/null +++ b/Master/tlpkg/tlperl/site/lib/Win32/API/Type.pm @@ -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 |