In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/8e88cfee26d866223a6b3bfffce6270271de00db?hp=6bbba9040c7840209170b2ff9a1d7b03ae1cbdc1>
- Log ----------------------------------------------------------------- commit 8e88cfee26d866223a6b3bfffce6270271de00db Author: Nicholas Clark <[email protected]> Date: Wed Dec 8 11:34:49 2010 +0000 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(). ----------------------------------------------------------------------- Summary of changes: dist/Storable/Storable.xs | 7 +++- dist/Storable/t/blessed.t | 63 +++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 66 insertions(+), 4 deletions(-) diff --git a/dist/Storable/Storable.xs b/dist/Storable/Storable.xs index 531855a..fa510b0 100644 --- 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 --- 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'; -- Perl5 Master Repository
