In Storable.xs fix #80074, caused by the Perl stack moving when expanded.

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().

diff --git a/dist/Storable/Storable.xs b/dist/Storable/Storable.xs
index 531855a..fa510b0 100644 (file)
--- a/dist/Storable/Storable.xs
+++ b/dist/Storable/Storable.xs
@@ -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

diff --git a/dist/Storable/t/blessed.t b/dist/Storable/t/blessed.t
index 657d23f..b8ae067 100644 (file)
--- a/dist/Storable/t/blessed.t
+++ b/dist/Storable/t/blessed.t
@@ -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';