1#!./perl -w 2# 3# Copyright 2005, Adam Kennedy. 4# 5# You may redistribute only under the same terms as Perl 5, as specified 6# in the README file that comes with the distribution. 7# 8 9# Man, blessed.t scared the hell out of me. For a second there I thought 10# I'd lose Test::More... 11 12# This file tests several known-error cases relating to STORABLE_attach, in 13# which Storable should (correctly) throw errors. 14 15sub BEGIN { 16 unshift @INC, 't'; 17 unshift @INC, 't/compat' if $] < 5.006002; 18 require Config; import Config; 19 if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { 20 print "1..0 # Skip: Storable was not built\n"; 21 exit 0; 22 } 23} 24 25use Storable (); 26use Test::More tests => 9; 27 28my $ddd = bless { }, 'Foo'; 29my $eee = bless { Bar => $ddd }, 'Bar'; 30$ddd->{Foo} = $eee; 31 32my $array = [ $ddd ]; 33 34my $string = Storable::freeze( $array ); 35my $thawed = Storable::thaw( $string ); 36 37# is_deeply infinite loops in circulars, so do it manually 38# is_deeply( $array, $thawed, 'Circular hooked objects work' ); 39is( ref($thawed), 'ARRAY', 'Top level ARRAY' ); 40is( scalar(@$thawed), 1, 'ARRAY contains one element' ); 41isa_ok( $thawed->[0], 'Foo' ); 42is( scalar(keys %{$thawed->[0]}), 1, 'Foo contains one element' ); 43isa_ok( $thawed->[0]->{Foo}, 'Bar' ); 44is( scalar(keys %{$thawed->[0]->{Foo}}), 1, 'Bar contains one element' ); 45isa_ok( $thawed->[0]->{Foo}->{Bar}, 'Foo' ); 46is( $thawed->[0], $thawed->[0]->{Foo}->{Bar}, 'Circular is... well... circular' ); 47 48# Make sure the thawing went the way we expected 49is_deeply( \@Foo::order, [ 'Bar', 'Foo' ], 'thaw order is correct (depth first)' ); 50 51 52 53 54 55package Foo; 56 57@order = (); 58 59sub STORABLE_freeze { 60 my ($self, $clone) = @_; 61 my $class = ref $self; 62 63 # print "# Freezing $class\n"; 64 65 return ($class, $self->{$class}); 66} 67 68sub STORABLE_thaw { 69 my ($self, $clone, $string, @refs) = @_; 70 my $class = ref $self; 71 72 # print "# Thawing $class\n"; 73 74 $self->{$class} = shift @refs; 75 76 push @order, $class; 77 78 return; 79} 80 81package Bar; 82 83BEGIN { 84@ISA = 'Foo'; 85} 86 871; 88