diff options
Diffstat (limited to 'Master/tlpkg/tlperl/site/lib/Win32/API/Type.pm')
-rw-r--r-- | Master/tlpkg/tlperl/site/lib/Win32/API/Type.pm | 590 |
1 files changed, 590 insertions, 0 deletions
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 |