From: Peter Rabbitson <ribasushi@cpan.org>
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?p=p5sagit%2FDevel-PeekPoke.git;a=commitdiff_plain;h=569e5f292f0a6cd954c8da5ce3f389d8dd8485ce

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;