From: Peter Rabbitson <ribasushi@cpan.org>
Date: Thu, 2 Feb 2012 17:48:35 +0000 (+0100)
Subject: Fix memory corruption - use a stack temp-value for the artificial string
X-Git-Tag: v0.02~5
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=36e403bb6734756c864c7fc84e7d48080cf75965;p=p5sagit%2FDevel-PeekPoke.git

Fix memory corruption - use a stack temp-value for the artificial string
---

diff --git a/Changes b/Changes
index 60cbcf8..1b92664 100644
--- a/Changes
+++ b/Changes
@@ -1,3 +1,5 @@
+    - Fix memory corruption issues by preempting perl garbage collection
+      of the artificial string PV
     - Fix describe_bytestring to work correctly with large offsets on
       32bit machines
 
diff --git a/lib/Devel/PeekPoke/PP.pm b/lib/Devel/PeekPoke/PP.pm
index a640bad..104722f 100644
--- a/lib/Devel/PeekPoke/PP.pm
+++ b/lib/Devel/PeekPoke/PP.pm
@@ -12,7 +12,7 @@ use Devel::PeekPoke::Constants qw/PTR_SIZE PTR_PACK_TYPE/;
 use B (); # for B::PV
 
 # we do not support every perl, as we rely on the implementation of SV/SvPV
-BEGIN { eval "sub __PERLVER () { $] }" };
+BEGIN { eval "sub __PERLVER () { '$]' }" };
 
 my ($svsize, $svu_offset, $xpv_size);
 # we know we start from 5.8.1
@@ -42,7 +42,7 @@ sub _pack_address {
 
   # 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 $_[0]"
+  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;
@@ -92,13 +92,24 @@ sub poke {
     substr( $sv_contents, 0, PTR_SIZE) = pack ('P', $xpv_contents );  # replace xpv in sv
   }
 
-  my $new_sv_ref = \ unpack( PTR_PACK_TYPE, pack( 'P', $sv_contents ) );
-  my $artificial_string = bless( $new_sv_ref, 'B::PV' )->object_2svref;
+  my $artificial_string = do {
+    # it is crucial to create a copy of $sv_contents, and work with a temporary
+    # memory location. Otherwise perl memory allocation will kick in and wreak
+    # considerable havoc culminating with an inevitable segfault
+    bless(
+      \ unpack(
+        PTR_PACK_TYPE,
+        do { no warnings 'pack'; pack( 'P', $sv_contents.'' ) },
+      ),
+      'B::PV',
+    )->object_2svref;
+  };
 
   # now when we write to the newly created "string" we are actually writing
   # to $location
   # note we HAVE to use lvalue substr - a plain assignment will add a \0
   substr($$artificial_string, 0, $len) = $bytes;
+
   return $len;
 }
 
diff --git a/t/03torture.t b/t/03torture.t
new file mode 100644
index 0000000..05247f0
--- /dev/null
+++ b/t/03torture.t
@@ -0,0 +1,28 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+use Devel::PeekPoke qw/peek poke peek_address poke_address/;
+use Devel::PeekPoke::Constants qw/PTR_SIZE PTR_PACK_TYPE/;
+
+my $str = 'for mutilation and mayhem';
+my $len = length($str);
+my $str_pv_addr = unpack(PTR_PACK_TYPE, pack('p', $str) );
+
+is( peek($str_pv_addr, $len + 1), $str . "\0", 'peek as expected (with NUL termination)' );
+
+for my $poke_size (2 .. $len) {
+  my $replace_chunk = 'a' . ( '0' x ($poke_size-1) );
+  for my $poke_start ( 0 .. ($len - $poke_size) ) {
+    $replace_chunk++;
+
+    my $expecting = $str;
+    substr($expecting, $poke_start, $poke_size, $replace_chunk);
+
+    poke($str_pv_addr+$poke_start, $replace_chunk);
+    is($str, $expecting, 'String matches expectation after poke');
+  }
+}
+
+done_testing;