summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Win32/API/Struct.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Win32/API/Struct.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/API/Struct.pm429
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;
}