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