From: Peter Rabbitson Date: Sat, 29 Dec 2012 08:36:59 +0000 (+0100) Subject: Fix Devel::PeekPoke on cygwin perls X-Git-Tag: v0.03~4 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=569e5f292f0a6cd954c8da5ce3f389d8dd8485ce;p=p5sagit%2FDevel-PeekPoke.git Fix Devel::PeekPoke on cygwin perls Apparently how data is written into a union larger than the variable type is entirely compiler/paltform dependent. In cases when ivsize > ptrsize we need to find out exactly which part of the (ivsize sized) svu_pv will hold the pointer before we go overwriting it. The previous assumption this offset is always 0 turned out to be false. Add some extra test suite diags while we are at it as well. --- diff --git a/Changes b/Changes index 37f0f15..65b8ab7 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,5 @@ + - Fix incorrect operation on some OSes (cygwin) when ptrsize < ivsize + 0.02 2012-03-20 09:45 (UTC) - Fix crashes when used in a threaded environment diff --git a/lib/Devel/PeekPoke/PP.pm b/lib/Devel/PeekPoke/PP.pm index ee72df0..9b6370f 100644 --- a/lib/Devel/PeekPoke/PP.pm +++ b/lib/Devel/PeekPoke/PP.pm @@ -16,6 +16,20 @@ use constant { _PERLVERSION => "$]", # we do not support every perl, as we rely on the implementation of SV/SvPV }; +sub _pack_address { + my ($digits) = (defined $_[0] and $_[0] =~ /^(\d+)$/) + or croak "Invalid address '$_[0]' - expecting an integer"; + + my $p = pack(PTR_PACK_TYPE, $_[0]); + + # FIXME - is there a saner way to check for overflows? + no warnings 'portable'; # hex() with a 64bit value + croak "Your system does not support addresses larger than 0x@{[ _MAX_ADDR ]}, you supplied $digits" + if ( $_[0] > hex(_MAX_ADDR) or uc(unpack('H*', $p)) eq _MAX_ADDR ); + + return $p; +} + BEGIN { # we know we start from 5.8.1 if ( (_PERLVERSION =~ /^5\.(\d{3})/)[0] % 2 ) { @@ -25,14 +39,38 @@ BEGIN { constant->import({ _SV_SIZE => PTR_SIZE + 4 + 4, # SvANY + 32bit refcnt + 32bit flags _XPV_SIZE => PTR_SIZE + $Config{sizesize} + $Config{sizesize}, # PVX ptr + cur + len - _SVU_OFFSET => 0, + _XPV_ADDR_OFFSET => undef, # it isn't really undefined, we just do not care }); } elsif (_PERLVERSION < 5.016) { + # The xpv address is written to the svu_pv, however we may get in trouble + # due to padding/alignment when ivsize (thus svu) is larger than PTR_SIZE + constant->import( _XPV_IN_SVU_OFFSET => $Config{ivsize} == PTR_SIZE ? 0 : do { + my $str = 'foo'; + my $packed_pv_addr = pack('p', $str); + my $svu_contents = unpack('P' . $Config{ivsize}, _pack_address(\$str + PTR_SIZE + 4 + 4) ); + + my $i = index $svu_contents, $packed_pv_addr; + if ($i < 0) { + require Devel::Peek; + printf STDERR + 'Unable to locate the XPV address 0x%X within SVU value 0x%s - ' + . "this can't be right. Please file a bug including this message and " + . "a full `perl -V` output (important).\n", + unpack(PTR_PACK_TYPE, $packed_pv_addr), + join('', map { sprintf '%X', $_ } unpack(PTR_PACK_TYPE . '*', $svu_contents ) ), + ; + Devel::Peek::Dump($str); + exit 1; + } + + $i; + }); + constant->import({ _SV_SIZE => PTR_SIZE + 4 + 4 + $Config{ivsize}, # SvANY + 32bit refcnt + 32bit flags + SV_U _XPV_SIZE => undef, # it isn't really undefined, we just do not care - _SVU_OFFSET => PTR_SIZE + 4 + 4, + _XPV_ADDR_OFFSET => PTR_SIZE + 4 + 4 + _XPV_IN_SVU_OFFSET(), # so we know where to write directly }); } else { @@ -41,20 +79,6 @@ BEGIN { } } -sub _pack_address { - my ($digits) = (defined $_[0] and $_[0] =~ /^(\d+)$/) - or croak "Invalid address '$_[0]' - expecting an integer"; - - my $p = pack(PTR_PACK_TYPE, $_[0]); - - # FIXME - is there a saner way to check for overflows? - no warnings 'portable'; # hex() with a 64bit value - croak "Your system does not support addresses larger than 0x@{[ _MAX_ADDR ]}, you supplied $digits" - if ( $_[0] > hex(_MAX_ADDR) or uc(unpack('H*', $p)) eq _MAX_ADDR ); - - return $p; -} - sub peek { #my($location, $len_bytes) = @_; croak "Peek where and how much?" unless (defined $_[0]) and $_[1]; @@ -100,7 +124,7 @@ sub poke { substr( $ghost_sv_contents, 0, PTR_SIZE) = pack ('P', $xpv_contents ); # replace xpv in sv } else { # new style 5.10+ SVs - substr( $ghost_sv_contents, _SVU_OFFSET, PTR_SIZE ) = $addr; + substr( $ghost_sv_contents, _XPV_ADDR_OFFSET, PTR_SIZE ) = $addr; } my $ghost_string_ref = bless( \ unpack( diff --git a/t/00info.t b/t/00info.t index afe80ba..e25d78b 100644 --- a/t/00info.t +++ b/t/00info.t @@ -3,9 +3,21 @@ use warnings; use Test::More; use Devel::PeekPoke::Constants qw/PTR_SIZE PTR_PACK_TYPE BIG_ENDIAN/; +use Config; diag("\nPerl: $]\n"); -diag(sprintf "%s: %s\n", $_, __PACKAGE__->$_ ) for (qw/BIG_ENDIAN PTR_SIZE PTR_PACK_TYPE/); +diag(sprintf "%s: %s\n", $_, __PACKAGE__->$_ ) for (qw/BIG_ENDIAN PTR_PACK_TYPE PTR_SIZE/); +diag("IV_SIZE: $Config{ivsize}\n"); + +if ( + PTR_SIZE != $Config{ivsize} + and + eval { require Devel::PeekPoke::PP } + and + defined (my $offset = eval { Devel::PeekPoke::PP::_XPV_IN_SVU_OFFSET() }) +) { + diag "Pointer offset within an IV_SIZEd UNION: $offset\n" +} ok('this is not a test, it just serves to diag() out what this system is using, for the curious (me)'); done_testing;