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