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.
[perl5.git] / dist / Storable / t / blessed.t
index 7c0494c..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 + 6 + 2 * 6 * keys %::immortals;
+my $tests = $test + 22 + 2 * 6 * keys %::immortals;
 print "1..$tests\n";
 
 package SHORT_NAME;
@@ -183,13 +183,70 @@ ok ++$test, $HAS_HOOK::thawed_count == 1;
 ok ++$test, $t;
 ok ++$test, ref $t eq 'HAS_HOOK';
 
-# Can't do this because the method is still cached by UNIVERSAL::can
-# delete $INC{"HAS_HOOK.pm"};
-# undef &HAS_HOOK::STORABLE_thaw;
-# 
-# warn HAS_HOOK->can('STORABLE_thaw');
-# $t = thaw $f;
-# ok ++$test, $HAS_HOOK::loaded_count == 2;
-# ok ++$test, $HAS_HOOK::thawed_count == 2;
-# ok ++$test, $t;
-# ok ++$test, ref $t eq 'HAS_HOOK';
+delete $INC{"HAS_HOOK.pm"};
+delete $HAS_HOOK::{STORABLE_thaw};
+
+$t = thaw $f;
+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';