summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/site/lib/Win32/API
diff options
context:
space:
mode:
authorKarl Berry <karl@freefriends.org>2016-04-05 22:27:26 +0000
committerKarl Berry <karl@freefriends.org>2016-04-05 22:27:26 +0000
commitb56b320b5e2515160073fa1b469514002688fe11 (patch)
tree965a7100c5e45fca8ec803d22b8b6ce14fca4633 /Master/tlpkg/tlperl/site/lib/Win32/API
parentd26c206452d2e285c3bbf949f34011e4a55fd8f9 (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.pm575
-rw-r--r--Master/tlpkg/tlperl/site/lib/Win32/API/Callback/IATPatch.pod181
-rw-r--r--Master/tlpkg/tlperl/site/lib/Win32/API/Struct.pm755
-rw-r--r--Master/tlpkg/tlperl/site/lib/Win32/API/Type.pm590
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