Commit | Line | Data |
---|---|---|
2f796f32 AMS |
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 | ||
15 | sub BEGIN { | |
48c887dd | 16 | unshift @INC, 't'; |
1afdebce | 17 | unshift @INC, 't/compat' if $] < 5.006002; |
2f796f32 AMS |
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 | ||
25 | use Storable (); | |
26 | use Test::More tests => 9; | |
27 | ||
28 | my $ddd = bless { }, 'Foo'; | |
29 | my $eee = bless { Bar => $ddd }, 'Bar'; | |
30 | $ddd->{Foo} = $eee; | |
31 | ||
32 | my $array = [ $ddd ]; | |
33 | ||
34 | my $string = Storable::freeze( $array ); | |
35 | my $thawed = Storable::thaw( $string ); | |
36 | ||
c4a6f826 | 37 | # is_deeply infinite loops in circulars, so do it manually |
2f796f32 AMS |
38 | # is_deeply( $array, $thawed, 'Circular hooked objects work' ); |
39 | is( ref($thawed), 'ARRAY', 'Top level ARRAY' ); | |
40 | is( scalar(@$thawed), 1, 'ARRAY contains one element' ); | |
41 | isa_ok( $thawed->[0], 'Foo' ); | |
42 | is( scalar(keys %{$thawed->[0]}), 1, 'Foo contains one element' ); | |
43 | isa_ok( $thawed->[0]->{Foo}, 'Bar' ); | |
44 | is( scalar(keys %{$thawed->[0]->{Foo}}), 1, 'Bar contains one element' ); | |
45 | isa_ok( $thawed->[0]->{Foo}->{Bar}, 'Foo' ); | |
46 | is( $thawed->[0], $thawed->[0]->{Foo}->{Bar}, 'Circular is... well... circular' ); | |
47 | ||
48 | # Make sure the thawing went the way we expected | |
49 | is_deeply( \@Foo::order, [ 'Bar', 'Foo' ], 'thaw order is correct (depth first)' ); | |
50 | ||
51 | ||
52 | ||
53 | ||
54 | ||
55 | package Foo; | |
56 | ||
57 | @order = (); | |
58 | ||
59 | sub 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 | ||
68 | sub 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 | ||
81 | package Bar; | |
82 | ||
83 | BEGIN { | |
84 | @ISA = 'Foo'; | |
85 | } | |
86 | ||
87 | 1; |