diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Win32/API/Type.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Win32/API/Type.pm | 272 |
1 files changed, 153 insertions, 119 deletions
diff --git a/Master/tlpkg/tlperl/lib/Win32/API/Type.pm b/Master/tlpkg/tlperl/lib/Win32/API/Type.pm index 48f0ce1a32f..90e6d1ca0ad 100644 --- a/Master/tlpkg/tlperl/lib/Win32/API/Type.pm +++ b/Master/tlpkg/tlperl/lib/Win32/API/Type.pm @@ -6,36 +6,36 @@ package Win32::API::Type; ####################################################################### # # Win32::API::Type - Perl Win32 API type definitions -# +# # Author: Aldo Calpini <dada@perl.it> # Maintainer: Cosimo Streppone <cosimo@cpan.org> # -# $Id: Type.pm 458 2009-01-17 17:27:43Z cosimo.streppone $ -# ####################################################################### -$VERSION = '0.59'; +$VERSION = '0.62'; use Carp; +use Config; -require Exporter; # to export the constants to the main:: space -require DynaLoader; # to dynuhlode the module. +require Exporter; # to export the constants to the main:: space +require DynaLoader; # to dynuhlode the module. @ISA = qw( Exporter DynaLoader ); use vars qw( %Known %PackSize %Modifier %Pointer ); -sub DEBUG { - if ($Win32::API::DEBUG) { - printf @_ if @_ or return 1; - } else { +sub DEBUG { + if ($Win32::API::DEBUG) { + printf @_ if @_ or return 1; + } + else { return 0; } } -%Known = (); -%PackSize = (); -%Modifier = (); -%Pointer = (); +%Known = (); +%PackSize = (); +%Modifier = (); +%Pointer = (); # Initialize data structures at startup. # Aldo wants to keep the <DATA> approach. @@ -44,29 +44,42 @@ my $section = 'nothing'; foreach (<DATA>) { next if /^\s*#/ or /^\s*$/; chomp; - if( /\[(.+)\]/) { + if (/\[(.+)\]/) { $section = $1; next; } - if($section eq 'TYPE') { - my($name, $packing) = split(/\s+/); + if ($section eq 'TYPE') { + my ($name, $packing) = split(/\s+/); + # DEBUG "(PM)Type::INIT: Known('$name') => '$packing'\n"; + if ($packing eq '_P') { + $packing = pointer_pack_type(); + } $Known{$name} = $packing; - } elsif($section eq 'PACKSIZE') { - my($packing, $size) = split(/\s+/); + } + elsif ($section eq 'PACKSIZE') { + my ($packing, $size) = split(/\s+/); + # DEBUG "(PM)Type::INIT: PackSize('$packing') => '$size'\n"; + if ($size eq '_P') { + $size = $Config{ptrsize}; + } $PackSize{$packing} = $size; - } elsif($section eq 'MODIFIER') { - my($modifier, $mapto) = split(/\s+/, $_, 2); + } + elsif ($section eq 'MODIFIER') { + my ($modifier, $mapto) = split(/\s+/, $_, 2); my %maps = (); foreach my $item (split(/\s+/, $mapto)) { - my($k, $v) = split(/=/, $item); + my ($k, $v) = split(/=/, $item); $maps{$k} = $v; - } + } + # DEBUG "(PM)Type::INIT: Modifier('$modifier') => '%maps'\n"; - $Modifier{$modifier} = { %maps }; - } elsif($section eq 'POINTER') { - my($pointer, $pointto) = split(/\s+/); + $Modifier{$modifier} = {%maps}; + } + elsif ($section eq 'POINTER') { + my ($pointer, $pointto) = split(/\s+/); + # DEBUG "(PM)Type::INIT: Pointer('$pointer') => '$pointto'\n"; $Pointer{$pointer} = $pointto; } @@ -74,21 +87,21 @@ foreach (<DATA>) { close(DATA); sub new { - my $class = shift; - my($type) = @_; + my $class = shift; + my ($type) = @_; my $packing = packing($type); - my $size = sizeof($type); - my $self = { - type => $type, + my $size = sizeof($type); + my $self = { + type => $type, packing => $packing, - size => $size, + size => $size, }; return bless $self; } sub typedef { my $class = shift; - my($name, $type) = @_; + my ($name, $type) = @_; my $packing = packing($type, $name); DEBUG "(PM)Type::typedef: packing='$packing'\n"; my $size = sizeof($type); @@ -101,88 +114,108 @@ sub is_known { my $self = shift; my $type = shift; $type = $self unless defined $type; - if(ref($type) =~ /Win32::API::Type/) { + if (ref($type) =~ /Win32::API::Type/) { return 1; - } else { + } + else { return defined packing($type); } } +sub pointer_pack_type { + return $Config{ptrsize} == 8 ? 'Q' : 'L'; +} + sub sizeof { my $self = shift; my $type = shift; $type = $self unless defined $type; - if(ref($type) =~ /Win32::API::Type/) { + if (ref($type) =~ /Win32::API::Type/) { return $self->{size}; - } else { + } + else { my $packing = packing($type); - if($packing =~ /(\w)\*(\d+)/) { - return $PackSize{ $1 } * $2; - } else { - return $PackSize{ $packing }; + if ($packing =~ /(\w)\*(\d+)/) { + return $PackSize{$1} * $2; + } + else { + return $PackSize{$packing}; } - } + } } sub packing { - # DEBUG "(PM)Type::packing: called by ". join("::", (caller(1))[0,3]). "\n"; - my $self = shift; + + # 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"; + 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; - - # DEBUG "(PM)Type::packing: got '$type', '$name'\n"; - my($modifier, $size, $packing); - if(exists $Pointer{$type}) { + + # 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}; + $type = $Pointer{$type}; $is_pointer = 1; - } elsif($type =~ /(\w+)\s+(\w+)/) { + } + elsif ($type =~ /(\w+)\s+(\w+)/) { $modifier = $1; - $type = $2; + $type = $2; + # DEBUG "(PM)packing: got modifier '$modifier', type '$type'\n"; } - + $type =~ s/\*$//; - - if(exists $Known{$type}) { - if(defined $name and $name =~ s/\[(.*)\]$//) { - $size = $1; - $packing = $Known{$type}[0]."*".$size; + + 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 { + } + else { $packing = $Known{$type}; - if($is_pointer and $packing eq 'c') { - $packing = "p"; + if ($is_pointer and $packing eq 'c') { + $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"; + if (defined $modifier and exists $Modifier{$modifier}->{$type}) { + +# DEBUG "(PM)Type::packing: applying modifier '$modifier' -> '$Modifier{$modifier}->{$type}'\n"; $packing = $Modifier{$modifier}->{$type}; } return $packing; - } else { + } + 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/) { + if (ref($type) =~ /Win32::API::Type/) { return 1; - } else { - if($type =~ /\*$/) { + } + else { + if ($type =~ /\*$/) { return 1; - } else { + } + else { return exists $Pointer{$type}; } } @@ -193,7 +226,7 @@ sub Pack { my $pack_type = packing($type); - if($pack_type eq 'p') { + if ($pack_type eq 'p') { $pack_type = 'Z*'; } @@ -207,14 +240,14 @@ sub Unpack { my $pack_type = packing($type); - if($pack_type eq 'p') { + if ($pack_type eq 'p') { DEBUG "(PM)Type::Unpack: got packing 'p': is a pointer\n"; $pack_type = 'Z*'; } - DEBUG "(PM)Type::Unpack: unpacking '$pack_type' '$arg'\n"; + DEBUG "(PM)Type::Unpack: unpacking '$pack_type' '$arg'\n"; $arg = unpack($pack_type, $arg); - DEBUG "(PM)Type::Unpack: returning '" . ($arg || '') . "'\n"; + DEBUG "(PM)Type::Unpack: returning '" . ($arg || '') . "'\n"; return $arg; } @@ -297,42 +330,43 @@ COLORREF L DWORD L DWORD32 L DWORD64 Q +DWORD_PTR _P FLOAT f -HACCEL L -HANDLE L -HBITMAP L -HBRUSH L -HCOLORSPACE L -HCONV L -HCONVLIST L -HCURSOR L -HDC L -HDDEDATA L -HDESK L -HDROP L -HDWP L -HENHMETAFILE L -HFILE L -HFONT L -HGDIOBJ L -HGLOBAL L -HHOOK L -HICON L -HIMC L -HINSTANCE L -HKEY L -HKL L -HLOCAL L -HMENU L -HMETAFILE L -HMODULE L -HPALETTE L -HPEN L -HRGN L -HRSRC L -HSZ L -HWINSTA L -HWND L +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 @@ -345,20 +379,20 @@ LONG l LONG32 l LONG64 q LONGLONG q -LPARAM L -LRESULT L +LPARAM _P +LRESULT _P REGSAM L -SC_HANDLE L -SC_LOCK L -SERVICE_STATUS_HANDLE L +SC_HANDLE _P +SC_LOCK _P +SERVICE_STATUS_HANDLE _P SHORT s -SIZE_T L -SSIZE_T L +SIZE_T _P +SSIZE_T _P TBYTE c TCHAR C UCHAR C UINT I -UINT_PTR L +UINT_PTR _P UINT32 I UINT64 Q ULONG L @@ -368,7 +402,7 @@ ULONGLONG Q USHORT S WCHAR S WORD S -WPARAM L +WPARAM _P VOID c int i @@ -396,7 +430,7 @@ q 8 Q 8 s 2 S 2 -p 4 +p _P [MODIFIER] unsigned int=I long=L short=S char=C |