diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Win32/API/Struct.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Win32/API/Struct.pm | 429 |
1 files changed, 224 insertions, 205 deletions
diff --git a/Master/tlpkg/tlperl/lib/Win32/API/Struct.pm b/Master/tlpkg/tlperl/lib/Win32/API/Struct.pm index 9f706671a77..3dda7d97e05 100644 --- a/Master/tlpkg/tlperl/lib/Win32/API/Struct.pm +++ b/Master/tlpkg/tlperl/lib/Win32/API/Struct.pm @@ -1,50 +1,45 @@ -package Win32::API::Struct; - -# See the bottom of this file for the POD documentation. Search for the -# string '=head'. - -####################################################################### # # Win32::API::Struct - Perl Win32 API struct Facility -# +# # Author: Aldo Calpini <dada@perl.it> # Maintainer: Cosimo Streppone <cosimo@cpan.org> # -# $Id: Struct.pm 438 2008-10-02 22:51:55Z cosimo.streppone $ -####################################################################### -$VERSION = '0.50'; +package Win32::API::Struct; -use Win32::API::Type; +$VERSION = '0.62'; use Carp; +use Win32::API::Type; +use Config; -require Exporter; # to export the constants to the main:: space -require DynaLoader; # to dynuhlode the module. -@ISA = qw( Exporter DynaLoader ); +require Exporter; +require DynaLoader; +@ISA = qw(Exporter DynaLoader); my %Known = (); -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; } } sub typedef { - my $class = shift; + my $class = shift; my $struct = shift; - my($type, $name); + my ($type, $name); my $self = { - align => undef, + align => undef, typedef => [], }; - while(defined($type = shift)) { + while (defined($type = shift)) { $name = shift; $name =~ s/;$//; - push( @{ $self->{typedef} }, [ recognize($type, $name) ] ); + push(@{$self->{typedef}}, [recognize($type, $name)]); } $Known{$struct} = $self; @@ -53,53 +48,59 @@ sub typedef { sub recognize { - my($type, $name) = @_; - my($size, $packing); - if(exists $Known{$type}) { - $packing = ">"; - return $name, $packing, $type; - } else { + my ($type, $name) = @_; + my ($size, $packing); + + if (is_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; + return undef unless defined $packing; + if ($name =~ s/\[(.*)\]$//) { + $size = $1; + $packing = $packing . '*' . $size; } DEBUG "(PM)Struct::recognize got '$name', '$type' -> '$packing'\n"; - return $name, $packing, $type; - } + return ($name, $packing, $type); + } } sub new { my $class = shift; - my($type, $name); - my $self = { - typedef => [], - }; - if($#_ == 0) { - if(exists $Known{$_[0]}) { + my ($type, $name); + my $self = {typedef => [],}; + if ($#_ == 0) { + if (is_known($_[0])) { DEBUG "(PM)Struct::new: got '$_[0]'\n"; $self->{typedef} = $Known{$_[0]}->{typedef}; - foreach my $member (@{ $self->{typedef} }) { + foreach my $member (@{$self->{typedef}}) { ($name, $packing, $type) = @$member; - if($packing eq '>') { + next unless defined $name; + if ($packing eq '>') { $self->{$name} = Win32::API::Struct->new($type); } } $self->{__typedef__} = $_[0]; - } else { + } + else { carp "Unknown Win32::API::Struct '$_[0]'"; return undef; } - } else { - while(defined($type = shift)) { + } + else { + while (defined($type = shift)) { $name = shift; + # print "new: found member $name ($type)\n"; - if(not exists $Win32::API::Type::Known{$type}) { + if (not exists $Win32::API::Type::Known{$type}) { warn "Unknown Win32::API::Struct type '$type'"; return undef; - } else { - push( @{ $self->{typedef} }, [ $name, $Win32::API::Type::Known{$type}, $type ] ); + } + else { + push(@{$self->{typedef}}, + [$name, $Win32::API::Type::Known{$type}, $type]); } } } @@ -108,201 +109,215 @@ sub new { sub members { my $self = shift; - return map {$_->[0]} @{ $self->{typedef} }; + return map { $_->[0] } @{$self->{typedef}}; } sub sizeof { - my $self = shift; - my $size = 0; + my $self = shift; + my $size = 0; my $align = 0; - my $first = undef; - foreach my $member (@{ $self->{typedef} }) { - my($name, $packing, $type) = @$member; - - if(ref( $self->{$name} ) eq "Win32::API::Struct") { + 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(); - # $align = $self->{$name}->sizeof() if $self->{$name}->sizeof() > $align; - } else { - if($packing =~ /\w\*(\d+)/) { + } + 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"; - } else { - $size += Win32::API::Type::sizeof($type); + $first = Win32::API::Type::sizeof($type) * $1 unless defined $first; + DEBUG "(PM)Struct::sizeof: sizeof with member($name) now = " . $size + . "\n"; + } + 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; - $align = Win32::API::Type::sizeof($type) - if Win32::API::Type::sizeof($type) > $align; - DEBUG "(PM)Struct::sizeof: sizeof with member($name) now = ". $size. "\n"; } } } - DEBUG "(PM)Struct::sizeof first=$first align=$align\n"; - #DEBUG "(PM)Struct::sizeof returning %d\n", $first + (scalar(@{ $self->{typedef} })-1) * $align; - #return $first + (scalar(@{ $self->{typedef} })-1) * $align; - DEBUG "(PM)Struct::sizeof returning %d\n", scalar(@{ $self->{typedef} }) * $align; - if(defined $align and $align > 0) { - return scalar(@{ $self->{typedef} }) * $align; - } else { - return $size; + + my $struct_size = $size; + if (defined $align && $align > 0) { + $struct_size += ($size % $align); } - return $size; + DEBUG "(PM)Struct::sizeof first=$first totalsize=$struct_size\n"; + return $struct_size; } sub align { - my $self = shift; - my $align = shift; - - if(not defined $align) { - return $self->{align} unless $self->{align} eq 'auto'; - $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; - - } + 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($type, $name); - my @items = (); - my @recipients = (); - + my $self = shift; + my $packing = ""; + my $packed_size = 0; + my ($type, $name, $type_size, $type_align); + my @items = (); + my @recipients = (); + my $align = $self->align(); - - foreach my $member (@{ $self->{typedef} }) { + + foreach my $member (@{$self->{typedef}}) { ($name, $type, $orig) = @$member; - if($type eq '>') { - my($subpacking, $subitems, $subrecipients) = $self->{$name}->getPack(); - + if ($type eq '>') { + my ($subpacking, $subitems, $subrecipients, $subpacksize) = + $self->{$name}->getPack(); DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $subpacking\n"; - - $packing .= $subpacking; - push(@items, @$subitems); + push(@items, @$subitems); push(@recipients, @$subrecipients); - } else { - if($type =~ /\w\*(\d+)/) { - my $size = $1; - $type = "a$size"; + $packing .= $subpacking; + $packed_size += $subpacksize; + } + else { + my $repeat = 1; + if ($type =~ /\w\*(\d+)/) { + $repeat = $1; + $type = "a$repeat"; } - - DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $type\n"; - - if($type eq 'p') { - $type = "L"; + + DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $type\n"; + + if ($type eq 'p') { + $type = ($Config{ptrsize} == 8) ? 'Q' : 'L'; push(@items, Win32::API::PointerTo($self->{$name})); - } else { - push(@items, $self->{$name}); } - $packing .= $type; - - if($Win32::API::Type::PackSize{$type} < $align) { - $packing .= ("x" x ($align - $Win32::API::Type::PackSize{$type})); + else { + push(@items, $self->{$name}); } - push(@recipients, $self); + $type_size = Win32::API::Type::sizeof($orig); + $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, @items)\n"; - return($packing, [@items], [@recipients]); + + DEBUG + "(PM)Struct::getPack: $self->{__typedef__}(buffer) = pack($packing, $packed_size)\n"; + + return ($packing, [@items], [@recipients], $packed_size); } - sub Pack { my $self = shift; - my($packing, $items, $recipients) = $self->getPack(); + my ($packing, $items, $recipients) = $self->getPack(); + DEBUG "(PM)Struct::Pack: $self->{__typedef__}(buffer) = pack($packing, @$items)\n"; + $self->{buffer} = pack($packing, @$items); - if(DEBUG) { - for my $i (0..$self->sizeof-1) { - printf " %3d: 0x%02x\n", $i, ord(substr($self->{buffer}, $i, 1)); + + if (DEBUG) { + for my $i (0 .. $self->sizeof - 1) { + printf "#pack# %3d: 0x%02x\n", $i, ord(substr($self->{buffer}, $i, 1)); } } - $self->{buffer_recipients} = $recipients + + $self->{buffer_recipients} = $recipients; } sub getUnpack { - my $self = shift; - my $packing = ""; - my($type, $name); + my $self = shift; + my $packing = ""; + my $packed_size = 0; + my ($type, $name, $type_size, $type_align); my @items = (); my $align = $self->align(); - foreach my $member (@{ $self->{typedef} }) { + foreach my $member (@{$self->{typedef}}) { ($name, $type, $orig) = @$member; - if($type eq '>') { - my($subpacking, @subitems) = $self->{$name}->getUnpack(); - + if ($type eq '>') { + my ($subpacking, $subpacksize, @subitems) = $self->{$name}->getUnpack(); DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $subpacking\n"; $packing .= $subpacking; - - + $packed_size += $subpacksize; push(@items, @subitems); - } else { - if($type =~ /\w\*(\d+)/) { - my $size = $1; - $type = "Z$size"; - } - - #if($type eq 'p') { - # $packing .= 'Z*'; - # DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ Z*\n"; - #} else { - $packing .= $type; - DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $type\n"; - #} - if($type ne 'p' and $type !~ /^Z(\d+)/ and $Win32::API::Type::PackSize{$type} < $align) { - DEBUG "(PM)Struct::getUnpack %s(%d) < %d\n", - $type, $Win32::API::Type::PackSize{$type}, $align - ; - $packing .= ("x" x ($align - $Win32::API::Type::PackSize{$type})); + } + else { + my $repeat = 1; + if ($type =~ /\w\*(\d+)/) { + $repeat = $1; + $type = "Z$repeat"; } + DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $type\n"; + $type_size = Win32::API::Type::sizeof($orig); + $type_align = (($packed_size + $type_size) % $type_size); + $packing .= "x" x $type_align . $type; + $packed_size += ( $type_size * $repeat ) + $type_align; push(@items, $name); } } DEBUG "(PM)Struct::getUnpack($self->{__typedef__}): unpack($packing, @items)\n"; - return($packing, @items); + return ($packing, $packed_size, @items); } sub Unpack { my $self = shift; - my($packing, @items) = $self->getUnpack(); + my ($packing, undef, @items) = $self->getUnpack(); my @itemvalue = unpack($packing, $self->{buffer}); DEBUG "(PM)Struct::Unpack: unpack($packing, buffer) = @itemvalue\n"; - foreach my $i (0..$#items) { + foreach my $i (0 .. $#items) { my $recipient = $self->{buffer_recipients}->[$i]; DEBUG "(PM)Struct::Unpack: %s(%s) = '%s' (0x%08x)\n", - $recipient->{__typedef__}, - $items[$i], - $itemvalue[$i], - $itemvalue[$i], - ; + $recipient->{__typedef__}, + $items[$i], + $itemvalue[$i], + $itemvalue[$i], + ; $recipient->{$items[$i]} = $itemvalue[$i]; - DEBUG "(PM)Struct::Unpack: self.$items[$i] = $self->{$items[$i]}\n"; + + # DEBUG "(PM)Struct::Unpack: self.items[$i] = $self->{$items[$i]}\n"; } } sub FromMemory { - my($self, $addr) = @_; + my ($self, $addr) = @_; DEBUG "(PM)Struct::FromMemory: doing Pack\n"; $self->Pack(); DEBUG "(PM)Struct::FromMemory: doing GetMemory( 0x%08x, %d )\n", $addr, $self->sizeof; - $self->{buffer} = Win32::API::ReadMemory( $addr, $self->sizeof ); + $self->{buffer} = Win32::API::ReadMemory($addr, $self->sizeof); $self->Unpack(); DEBUG "(PM)Struct::FromMemory: doing Unpack\n"; DEBUG "(PM)Struct::FromMemory: structure is now:\n"; @@ -311,26 +326,28 @@ sub FromMemory { } sub Dump { - my $self = shift; + my $self = shift; my $prefix = shift; - foreach my $member (@{ $self->{typedef} }) { + foreach my $member (@{$self->{typedef}}) { ($name, $packing, $type) = @$member; - if( ref($self->{$name}) ) { + if (ref($self->{$name})) { $self->{$name}->Dump($name); - } else { + } + else { printf "%-20s %-20s %-20s\n", $prefix, $name, $self->{$name}; } } -} +} sub is_known { my $name = shift; - if(exists $Known{ $name }) { - return 1; - } else { - if($name =~ s/^LP//) { - return exists $Known{ $name }; + if (exists $Known{$name}) { + return 1; + } + else { + if ($name =~ s/^LP//) { + return exists $Known{$name}; } return 0; } @@ -346,42 +363,44 @@ sub EXISTS { sub FETCH { my $self = shift; - my $key = shift; - - if($key eq 'sizeof') { + my $key = shift; + + if ($key eq 'sizeof') { return $self->sizeof; } - my @members = map { $_->[0] } @{ $self->{typedef} }; - if(grep(/^\Q$key\E$/, @members)) { + my @members = map { $_->[0] } @{$self->{typedef}}; + if (grep(/^\Q$key\E$/, @members)) { return $self->{$key}; - } else { + } + 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)) { + my ($key, $val) = @_; + my @members = map { $_->[0] } @{$self->{typedef}}; + if (grep(/^\Q$key\E$/, @members)) { $self->{$key} = $val; - } else { + } + 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]; + 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; + 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; } |