From: Peter Rabbitson <ribasushi@cpan.org>
Date: Sat, 11 Feb 2012 22:11:48 +0000 (+0100)
Subject: Make D::PP threadsafe with tests
X-Git-Tag: v0.02~2
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit%2FDevel-PeekPoke.git;a=commitdiff_plain;h=24538b0888de38ff5417c0c5dcf5679905d40fb7;hp=9b733ba16504382fc5e5d765ccf5a4f405ea3933

Make D::PP threadsafe with tests
---

diff --git a/Changes b/Changes
index 1b92664..50b15b0 100644
--- a/Changes
+++ b/Changes
@@ -1,3 +1,4 @@
+    - Fix crashes when used in a threaded environment
     - Fix memory corruption issues by preempting perl garbage collection
       of the artificial string PV
     - Fix describe_bytestring to work correctly with large offsets on
diff --git a/lib/Devel/PeekPoke/PP.pm b/lib/Devel/PeekPoke/PP.pm
index 028496a..ee72df0 100644
--- a/lib/Devel/PeekPoke/PP.pm
+++ b/lib/Devel/PeekPoke/PP.pm
@@ -69,6 +69,9 @@ sub poke {
   my($location, $bytes) = @_;
   croak "Poke where and what?" unless (defined $location) and (defined $bytes);
 
+  # sanity check and properly pack address
+  my $addr = _pack_address($location);
+
   # sanity check is (imho) warranted as described here:
   # http://blogs.perl.org/users/aristotle/2011/08/utf8-flag.html#comment-36499
   if (utf8::is_utf8($bytes) and $bytes  =~ /([^\x00-\x7F])/) {
@@ -93,11 +96,11 @@ sub poke {
     my $xpv_addr = unpack(PTR_PACK_TYPE, peek($dummy_addr, PTR_SIZE) );
     my $xpv_contents = peek( $xpv_addr, _XPV_SIZE ); # we do not care about cur/len (they will be the same)
 
-    substr( $xpv_contents, 0, PTR_SIZE ) = _pack_address($location);  # replace pvx in xpv with sanity-checked $location
+    substr( $xpv_contents, 0, PTR_SIZE ) = $addr;  # replace pvx in xpv with the "string buffer" location
     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 ) = _pack_address($location);
+    substr( $ghost_sv_contents, _SVU_OFFSET, PTR_SIZE ) = $addr;
   }
 
   my $ghost_string_ref = bless( \ unpack(
@@ -111,7 +114,10 @@ sub poke {
   # 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($$ghost_string_ref, 0, $len) = $bytes;
+  #
+  # Also in order to keep threading on perl 5.8.x happy we *have* to perform this
+  # in a string eval. I don't have the slightest idea why :)
+  eval 'substr($$ghost_string_ref, 0, $len) = $bytes';
 
   return $len;
 }
diff --git a/t/03torture.t b/t/03torture.t
index 13d80ea..6e4eb6b 100644
--- a/t/03torture.t
+++ b/t/03torture.t
@@ -4,14 +4,19 @@ use warnings;
 # T::M appears to leak, emit the TAP by hand
 #use Test::More 'no_plan';
 
-my $tests = 0;
 sub is {
-  $tests++;
-  printf("%s %u - %s\n",
-    ( $_[0] eq $_[1] ? 'ok' : 'not ok' ),
-    $tests,
-    $_[2] || '',
-  );
+  my $str = $_[0] eq $_[1] ? 'ok' : 'not ok';
+
+  {
+    lock($::TEST_COUNT);
+    $::TEST_COUNT++;
+    printf STDOUT ("%s %u - %s\n",
+      $str,
+      $::TEST_COUNT,
+      $_[2] || '',
+    );
+  }
+  threads->yield if $INC{'threads.pm'};
 }
 
 use Devel::PeekPoke qw/peek poke peek_address poke_address/;
@@ -23,7 +28,7 @@ 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 (1 .. ($ENV{AUTOMATED_TESTING} ? 300 : 20) ) {
+for (1 .. ($ENV{AUTOMATED_TESTING} ? 200 : 20 ) ) {
   for my $poke_size (2 .. $len) {
     my $replace_chunk = 'a' . ( '0' x ($poke_size-1) );
     for my $poke_start ( 0 .. ($len - $poke_size) ) {
@@ -38,7 +43,7 @@ for (1 .. ($ENV{AUTOMATED_TESTING} ? 300 : 20) ) {
   }
 }
 
-if ($ENV{AUTOMATED_TESTING}) {
+if ($ENV{AUTOMATED_TESTING} and ! $INC{'threads.pm'}) {
   my $vsz;
   if (-f "/proc/$$/stat") {
     my $proc_stat = do { local (@ARGV, $/) = "/proc/$$/stat"; <> };
@@ -50,4 +55,4 @@ if ($ENV{AUTOMATED_TESTING}) {
     if $vsz;
 }
 
-print "1..$tests\n";
+print "1..$::TEST_COUNT\n" unless $INC{'threads.pm'};
diff --git a/t/04thread-torture.t b/t/04thread-torture.t
new file mode 100644
index 0000000..2424aae
--- /dev/null
+++ b/t/04thread-torture.t
@@ -0,0 +1,43 @@
+use Config;
+BEGIN {
+  unless ($Config{useithreads}) {
+    print "1..0 # SKIP your perl does not support ithreads\n";
+    exit 0;
+  }
+}
+
+use threads;
+use threads::shared;
+
+use strict;
+use warnings;
+no warnings 'once';
+use Time::HiRes 'sleep';
+
+$|++; # seems to be critical
+
+share $::TEST_COUNT;
+
+# older perls crash if threads are spawned way too quickly, sleep for 100 msecs
+my @pool = map { sleep 0.1 and threads->create(\&run_torture) } (1..10);
+$_->join for @pool;
+
+if ($ENV{AUTOMATED_TESTING}) {
+  my $vsz;
+  if (-f "/proc/$$/stat") {
+    my $proc_stat = do { local (@ARGV, $/) = "/proc/$$/stat"; <> };
+    ($vsz) = map { $_ / 1024 }
+      (split (/\s+/, $proc_stat))[-22];  # go backwards because the %s of the procname can contain anything
+  }
+
+  printf STDERR "#\n# VSIZE:%dKiB\n", $vsz
+    if $vsz;
+}
+
+print "1..$::TEST_COUNT\n";
+
+sub run_torture {
+  my $src = do { local (@ARGV, $/) = 't/03torture.t'; <>; };
+  eval $src;
+  die $@ if $@ ne '';
+}