diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Win32/API/Struct.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Win32/API/Struct.pm | 245 |
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> ). |