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 | # Tests freezing/thawing structures containing Singleton objects, |
10 | # which should see both structs pointing to the same object. |
11 | |
12 | sub BEGIN { |
13 | if ($ENV{PERL_CORE}){ |
14 | chdir('t') if -d 't'; |
15 | @INC = ('.', '../lib'); |
16 | } else { |
17 | unshift @INC, 't'; |
18 | } |
19 | require Config; import Config; |
20 | if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { |
21 | print "1..0 # Skip: Storable was not built\n"; |
22 | exit 0; |
23 | } |
24 | } |
25 | |
26 | use Test::More tests => 11; |
27 | use Storable (); |
28 | |
29 | # Get the singleton |
30 | my $object = My::Singleton->new; |
31 | isa_ok( $object, 'My::Singleton' ); |
32 | |
33 | # Confirm (for the record) that the class is actually a Singleton |
34 | my $object2 = My::Singleton->new; |
35 | isa_ok( $object2, 'My::Singleton' ); |
36 | is( "$object", "$object2", 'Class is a singleton' ); |
37 | |
38 | ############ |
39 | # Main Tests |
40 | |
41 | my $struct = [ 1, $object, 3 ]; |
42 | |
43 | # Freeze the struct |
44 | my $frozen = Storable::freeze( $struct ); |
45 | ok( (defined($frozen) and ! ref($frozen) and length($frozen)), 'freeze returns a string' ); |
46 | |
47 | # Thaw the struct |
48 | my $thawed = Storable::thaw( $frozen ); |
49 | |
50 | # Now it should look exactly like the original |
51 | is_deeply( $struct, $thawed, 'Struct superficially looks like the original' ); |
52 | |
53 | # ... EXCEPT that the Singleton should be the same instance of the object |
54 | is( "$struct->[1]", "$thawed->[1]", 'Singleton thaws correctly' ); |
55 | |
56 | # We can also test this empirically |
57 | $struct->[1]->{value} = 'Goodbye cruel world!'; |
58 | is_deeply( $struct, $thawed, 'Empiric testing corfirms correct behaviour' ); |
59 | |
60 | # End Tests |
61 | ########### |
62 | |
63 | package My::Singleton; |
64 | |
65 | my $SINGLETON = undef; |
66 | |
67 | sub new { |
68 | $SINGLETON or |
69 | $SINGLETON = bless { value => 'Hello World!' }, $_[0]; |
70 | } |
71 | |
72 | sub STORABLE_freeze { |
73 | my $self = shift; |
74 | |
75 | # We don't actually need to return anything, but provide a null string |
76 | # to avoid the null-list-return behaviour. |
77 | return ('foo'); |
78 | } |
79 | |
80 | sub STORABLE_attach { |
81 | my ($class, $clone, $string) = @_; |
82 | Test::More::ok( ! ref $class, 'STORABLE_attach passed class, and not an object' ); |
83 | Test::More::is( $class, 'My::Singleton', 'STORABLE_attach is passed the correct class name' ); |
84 | Test::More::is( $clone, 0, 'We are not in a dclone' ); |
85 | Test::More::is( $string, 'foo', 'STORABLE_attach gets the string back' ); |
86 | |
87 | # Get the Singleton object and return it |
88 | return $class->new; |
89 | } |