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.pm245
1 files changed, 204 insertions, 41 deletions
diff --git a/Master/tlpkg/tlperl/lib/Win32/API/Struct.pm b/Master/tlpkg/tlperl/lib/Win32/API/Struct.pm
index 3dda7d97e05..9a67ed7b6c4 100644
--- a/Master/tlpkg/tlperl/lib/Win32/API/Struct.pm
+++ b/Master/tlpkg/tlperl/lib/Win32/API/Struct.pm
@@ -6,8 +6,10 @@
#
package Win32::API::Struct;
-
-$VERSION = '0.62';
+use strict;
+use warnings;
+use vars qw( $VERSION @ISA );
+$VERSION = '0.65';
use Carp;
use Win32::API::Type;
@@ -31,7 +33,7 @@ sub DEBUG {
sub typedef {
my $class = shift;
my $struct = shift;
- my ($type, $name);
+ my ($type, $name, @recog_arr);
my $self = {
align => undef,
typedef => [],
@@ -39,19 +41,51 @@ sub typedef {
while (defined($type = shift)) {
$name = shift;
$name =~ s/;$//;
- push(@{$self->{typedef}}, [recognize($type, $name)]);
+ @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){
+ carp "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;
+ croak("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 (is_known($type)) {
+ if (exists $Known{$type}) {
$packing = '>';
return ($name, $packing, $type);
}
@@ -69,12 +103,15 @@ sub recognize {
sub new {
my $class = shift;
- my ($type, $name);
+ my ($type, $name, $packing);
my $self = {typedef => [],};
if ($#_ == 0) {
if (is_known($_[0])) {
DEBUG "(PM)Struct::new: got '$_[0]'\n";
- $self->{typedef} = $Known{$_[0]}->{typedef};
+ if( ! defined ($self->{typedef} = $Known{$_[0]}->{typedef})){
+ carp 'Win32::API::Struct::new: unknown type="'.$_[0].'"';
+ return undef;
+ }
foreach my $member (@{$self->{typedef}}) {
($name, $packing, $type) = @$member;
next unless defined $name;
@@ -95,7 +132,7 @@ sub new {
# print "new: found member $name ($type)\n";
if (not exists $Win32::API::Type::Known{$type}) {
- warn "Unknown Win32::API::Struct type '$type'";
+ carp "Unknown Win32::API::Struct type '$type'";
return undef;
}
else {
@@ -197,17 +234,22 @@ sub getPack {
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}}) {
- ($name, $type, $orig) = @$member;
+ my ($name, $type, $orig) = @$member;
if ($type eq '>') {
- my ($subpacking, $subitems, $subrecipients, $subpacksize) =
+ my ($subpacking, $subitems, $subrecipients, $subpacksize, $subbuffersptrs) =
$self->{$name}->getPack();
DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $subpacking\n";
push(@items, @$subitems);
push(@recipients, @$subrecipients);
+ push(@buffer_ptrs, @$subbuffersptrs);
$packing .= $subpacking;
$packed_size += $subpacksize;
}
@@ -221,9 +263,22 @@ sub getPack {
DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $type\n";
if ($type eq 'p') {
- $type = ($Config{ptrsize} == 8) ? 'Q' : 'L';
+ $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});
}
@@ -238,43 +293,59 @@ sub getPack {
DEBUG
"(PM)Struct::getPack: $self->{__typedef__}(buffer) = pack($packing, $packed_size)\n";
- return ($packing, [@items], [@recipients], $packed_size);
+ return ($packing, [@items], [@recipients], $packed_size, \@buffer_ptrs);
}
+# void $struct->Pack([$priv_warnings_flag]);
sub Pack {
my $self = shift;
- my ($packing, $items, $recipients) = $self->getPack();
+ my ($packing, $items);
+ ($packing, $items, $self->{buffer_recipients},
+ undef, $self->{buffer_ptrs}) = $self->getPack();
+ if(DEBUG){
DEBUG "(PM)Struct::Pack: $self->{__typedef__}(buffer) = pack($packing, @$items)\n";
-
- $self->{buffer} = pack($packing, @$items);
-
+ }
+
+ 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()
+ no warnings 'uninitialized';
+ $self->{buffer} = pack($packing, @$items);
+ }
+ else{
+ $self->{buffer} = pack($packing, @$items);
+ }
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;
}
sub getUnpack {
my $self = shift;
my $packing = "";
my $packed_size = 0;
- my ($type, $name, $type_size, $type_align);
- my @items = ();
+ my ($type, $name, $type_size, $type_align, $orig_type);
+ my (@items, @types, @type_names);
my $align = $self->align();
foreach my $member (@{$self->{typedef}}) {
- ($name, $type, $orig) = @$member;
+ my ($name, $type, $orig) = @$member;
if ($type eq '>') {
- my ($subpacking, $subpacksize, @subitems) = $self->{$name}->getUnpack();
+ my ($subpacking, $subpacksize, $subitems, $subtypes, $subtype_names) = $self->{$name}->getUnpack();
DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $subpacking\n";
$packing .= $subpacking;
$packed_size += $subpacksize;
- push(@items, @subitems);
+ 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();
+ }
my $repeat = 1;
if ($type =~ /\w\*(\d+)/) {
$repeat = $1;
@@ -285,30 +356,76 @@ sub getUnpack {
$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";
- return ($packing, $packed_size, @items);
+ return ($packing, $packed_size, \@items, \@types, \@type_names);
}
sub Unpack {
my $self = shift;
- my ($packing, undef, @items) = $self->getUnpack();
+ my ($packing, undef, $items, $types, $type_names) = $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];
+ my $item = $$items[$i];
DEBUG "(PM)Struct::Unpack: %s(%s) = '%s' (0x%08x)\n",
$recipient->{__typedef__},
- $items[$i],
+ $item,
$itemvalue[$i],
$itemvalue[$i],
;
- $recipient->{$items[$i]} = $itemvalue[$i];
+ if($$types[$i] 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
+ carp "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
+ carp "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
+ $recipient->{$item} = $itemvalue[$i];
- # DEBUG "(PM)Struct::Unpack: self.items[$i] = $self->{$items[$i]}\n";
+ # DEBUG "(PM)Struct::Unpack: self.items[$i] = $self->{$$items[$i]}\n";
+ }
}
}
@@ -329,7 +446,7 @@ sub Dump {
my $self = shift;
my $prefix = shift;
foreach my $member (@{$self->{typedef}}) {
- ($name, $packing, $type) = @$member;
+ my ($name, $packing, $type) = @$member;
if (ref($self->{$name})) {
$self->{$name}->Dump($name);
}
@@ -339,15 +456,22 @@ sub Dump {
}
}
-
+#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 {
- if ($name =~ s/^LP//) {
- return exists $Known{$name};
+ my $nametest = $name;
+ if ($nametest =~ s/^LP//) {
+ return exists $Known{$nametest};
+ }
+ $nametest = $name;
+ if($nametest =~ s/\*$//){
+ return exists $Known{$nametest};
}
return 0;
}
@@ -440,7 +564,7 @@ Win32::API::Struct - C struct support package for Win32::API
This module enables you to define C structs for use with
Win32::API.
-See L<Win32::API> for more info about its usage.
+See L<Win32::API/USING STRUCTURES> for more info about its usage.
=head1 DESCRIPTION
@@ -457,7 +581,11 @@ 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.
+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:
@@ -471,11 +599,14 @@ syntax), which is pretty cool:
LONG y;
};
-Also note that C<typedef> automatically defines an 'LPNAME' type,
-which holds a pointer to your structure. In the example above,
-'LPPOINT' is also defined and can be used in a call to a
-Win32::API (in fact, this is what you're really going to use when
-doing API calls).
+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>
@@ -540,6 +671,38 @@ remember to backslash it, eg.
=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> ).