Commit | Line | Data |
2f796f32 |
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'; |
2f796f32 |
17 | require Config; import Config; |
18 | if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { |
19 | print "1..0 # Skip: Storable was not built\n"; |
20 | exit 0; |
21 | } |
22 | } |
23 | |
24 | use Storable (); |
25 | use Test::More tests => 9; |
26 | |
27 | my $ddd = bless { }, 'Foo'; |
28 | my $eee = bless { Bar => $ddd }, 'Bar'; |
29 | $ddd->{Foo} = $eee; |
30 | |
31 | my $array = [ $ddd ]; |
32 | |
33 | my $string = Storable::freeze( $array ); |
34 | my $thawed = Storable::thaw( $string ); |
35 | |
36 | # is_deeply infinite loops in ciculars, so do it manually |
37 | # is_deeply( $array, $thawed, 'Circular hooked objects work' ); |
38 | is( ref($thawed), 'ARRAY', 'Top level ARRAY' ); |
39 | is( scalar(@$thawed), 1, 'ARRAY contains one element' ); |
40 | isa_ok( $thawed->[0], 'Foo' ); |
41 | is( scalar(keys %{$thawed->[0]}), 1, 'Foo contains one element' ); |
42 | isa_ok( $thawed->[0]->{Foo}, 'Bar' ); |
43 | is( scalar(keys %{$thawed->[0]->{Foo}}), 1, 'Bar contains one element' ); |
44 | isa_ok( $thawed->[0]->{Foo}->{Bar}, 'Foo' ); |
45 | is( $thawed->[0], $thawed->[0]->{Foo}->{Bar}, 'Circular is... well... circular' ); |
46 | |
47 | # Make sure the thawing went the way we expected |
48 | is_deeply( \@Foo::order, [ 'Bar', 'Foo' ], 'thaw order is correct (depth first)' ); |
49 | |
50 | |
51 | |
52 | |
53 | |
54 | package Foo; |
55 | |
56 | @order = (); |
57 | |
58 | sub STORABLE_freeze { |
59 | my ($self, $clone) = @_; |
60 | my $class = ref $self; |
61 | |
62 | # print "# Freezing $class\n"; |
63 | |
64 | return ($class, $self->{$class}); |
65 | } |
66 | |
67 | sub STORABLE_thaw { |
68 | my ($self, $clone, $string, @refs) = @_; |
69 | my $class = ref $self; |
70 | |
71 | # print "# Thawing $class\n"; |
72 | |
73 | $self->{$class} = shift @refs; |
74 | |
75 | push @order, $class; |
76 | |
77 | return; |
78 | } |
79 | |
80 | package Bar; |
81 | |
82 | BEGIN { |
83 | @ISA = 'Foo'; |
84 | } |
85 | |
86 | 1; |