This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
In Storable.xs fix #80074, caused by the Perl stack moving when expanded.
authorNicholas Clark <nick@ccl4.org>
Wed, 8 Dec 2010 11:34:49 +0000 (11:34 +0000)
committerNicholas Clark <nick@ccl4.org>
Wed, 8 Dec 2010 12:01:22 +0000 (12:01 +0000)
cbc736f3c4431a04 refactored Storable::{net_,}pstore to simplify the logic in
their caller, Storable::_store(). However, it introduced a bug, by assigning
the result of do_store() to a location on the Perl stack, which fails if the
Perl stack moves, because it was reallocated. Fix this assumption, and add a
test which causes the Perl stack to expand during the call to do_store().

dist/Storable/Storable.xs
dist/Storable/t/blessed.t

index 531855a..fa510b0 100644 (file)
@@ -6386,14 +6386,17 @@ init_perinterp()
 # Same as pstore(), but network order is used for integers and doubles are
 # emitted as strings.
 
-void
+SV *
 pstore(f,obj)
 OutputStream   f
 SV *   obj
  ALIAS:
   net_pstore = 1
  PPCODE:
-  ST(0) = do_store(aTHX_ f, obj, 0, ix, (SV **)0) ? &PL_sv_yes : &PL_sv_undef;
+  RETVAL = do_store(aTHX_ f, obj, 0, ix, (SV **)0) ? &PL_sv_yes : &PL_sv_undef;
+  /* do_store() can reallocate the stack, so need a sequence point to ensure
+     that ST(0) knows about it. Hence using two statements.  */
+  ST(0) = RETVAL;
   XSRETURN(1);
 
 # mstore
index 657d23f..b8ae067 100644 (file)
@@ -18,7 +18,7 @@ sub BEGIN {
 
 sub ok;
 
-use Storable qw(freeze thaw);
+use Storable qw(freeze thaw store retrieve);
 
 %::immortals
   = (u => \undef,
@@ -27,7 +27,7 @@ use Storable qw(freeze thaw);
 );
 
 my $test = 12;
-my $tests = $test + 10 + 2 * 6 * keys %::immortals;
+my $tests = $test + 22 + 2 * 6 * keys %::immortals;
 print "1..$tests\n";
 
 package SHORT_NAME;
@@ -191,3 +191,62 @@ ok ++$test, $HAS_HOOK::loaded_count == 2;
 ok ++$test, $HAS_HOOK::thawed_count == 2;
 ok ++$test, $t;
 ok ++$test, ref $t eq 'HAS_HOOK';
+
+{
+    package STRESS_THE_STACK;
+
+    my $stress;
+    sub make {
+       bless [];
+    }
+
+    sub no_op {
+       0;
+    }
+
+    sub STORABLE_freeze {
+       my $self = shift;
+       ++$freeze_count;
+       return no_op(1..(++$stress * 2000)) ? die "can't happen" : '';
+    }
+
+    sub STORABLE_thaw {
+       my $self = shift;
+       ++$thaw_count;
+       no_op(1..(++$stress * 2000)) && die "can't happen";
+       return;
+    }
+}
+
+$STRESS_THE_STACK::freeze_count = 0;
+$STRESS_THE_STACK::thaw_count = 0;
+
+$f = freeze (STRESS_THE_STACK->make);
+
+ok ++$test, $STRESS_THE_STACK::freeze_count == 1;
+ok ++$test, $STRESS_THE_STACK::thaw_count == 0;
+
+$t = thaw $f;
+ok ++$test, $STRESS_THE_STACK::freeze_count == 1;
+ok ++$test, $STRESS_THE_STACK::thaw_count == 1;
+ok ++$test, $t;
+ok ++$test, ref $t eq 'STRESS_THE_STACK';
+
+my $file = "storable-testfile.$$";
+die "Temporary file '$file' already exists" if -e $file;
+
+END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }}
+
+$STRESS_THE_STACK::freeze_count = 0;
+$STRESS_THE_STACK::thaw_count = 0;
+
+store (STRESS_THE_STACK->make, $file);
+
+ok ++$test, $STRESS_THE_STACK::freeze_count == 1;
+ok ++$test, $STRESS_THE_STACK::thaw_count == 0;
+
+$t = retrieve ($file);
+ok ++$test, $STRESS_THE_STACK::freeze_count == 1;
+ok ++$test, $STRESS_THE_STACK::thaw_count == 1;
+ok ++$test, $t;
+ok ++$test, ref $t eq 'STRESS_THE_STACK';