1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
|
package main;
use Test::More tests => 43;
use strict;
package TestClass;
use Class::Std::Storable;
{
my %name_of :ATTR( :get<name> :set<name> );
my %flavor_of :ATTR( :get<flavor> :set<flavor> );
}
package LinkedList;
use Class::Std::Storable;
{
my %info_of :ATTR( :get<info> :set<info> );
my %next_node_for :ATTR( :get<next_node> :set<next_node> );
}
package TestMISubClass;
use Class::Std::Storable;
use base qw( TestClass LinkedList );
{
my %ref_copy_for :ATTR( :get<ref_copy> );
my %unknown1 :ATTR; #for testing with no attr name given
my %unknown2 :ATTR; #for testing with no attr name given
sub set_next_node {
my $self = shift;
my $id = ident $self;
die "no param provided" unless @_;
my $next_node = shift;
$ref_copy_for{$id} = $next_node;
$self->SUPER::set_next_node($next_node);
return;
}
sub set_unknown1 {
my $id = ident shift;
$unknown1{$id} = shift;
}
sub get_unknown1 {
return $unknown1{ident shift};
}
sub set_unknown2 {
my $id = ident shift;
$unknown2{$id} = shift;
}
sub get_unknown2 {
return $unknown2{ident shift};
}
}
package main;
use Class::Std::Storable;
use Storable;
use Carp;
use Data::Dumper;
##########################################################
# very basic testing of a single object
my $object = TestClass->new;
$object->set_name("Vanilla Bean");
$object->set_flavor("vanilla");
my $clone = Storable::dclone($object);
is( $clone->get_name, "Vanilla Bean", "properties successfully cloned");
is( $clone->get_flavor, "vanilla", "properties successfully cloned");
##########################################################
# testing a nested structure
my $first_node = LinkedList->new;
$first_node->set_info(1);
for my $i (2..10) {
my $next_node = LinkedList->new;
$next_node->set_info($i);
$next_node->set_next_node($first_node);
$first_node = $next_node;
}
my $id = ident($first_node);
$first_node = Storable::dclone($first_node);
isnt($id, ident($first_node), "should in fact be a different object");
for my $i (reverse 1..10) {
is($first_node->get_info, $i, "values in the nodes all match");
$first_node = $first_node->get_next_node;
}
##########################################################
# testing MI and structural integrity
my @flavors = qw( vanilla chocolate strawberry mango peach grape );
my $obj;
for my $flavor ( @flavors ) {
my $next = TestMISubClass->new;
$next->set_flavor($flavor);
$next->set_info($flavor);
$next->set_unknown1("1_$flavor");
$next->set_unknown2("2_$flavor");
$next->set_next_node($obj);
$obj = $next;
}
$clone = Storable::freeze($obj);
undef $obj; #should destroy the whole list
$clone = Storable::thaw($clone);
for my $flavor ( reverse @flavors ) {
is($flavor, $clone->get_flavor, "flavor cloned the same");
is("1_$flavor", $clone->get_unknown1, "unknown1 cloned the same");
is("2_$flavor", $clone->get_unknown2, "unknown2 cloned the same");
my $next = $clone->get_next_node;
my $copy = $clone->get_ref_copy;
last unless $next;
is(ident($next), ident($copy), "clones of same object should be the same");
$clone = $next;
}
##########################################################
# generating diagnostics
$object = TestClass->new;
$object->set_name("Vanilla Bean");
$object->set_flavor("vanilla");
eval { $object->STORABLE_thaw(0, 0, {TestClass => { name => "foo" } } ) };
like($@, qr{trying to modify existing attributes}, "block attempted manipulation");
eval { $object->STORABLE_thaw(0, 0, {TestClass => { unknown => "foo" } } ) };
like($@, qr{unknown attribute}, "error on unknown attribute");
eval { $object->STORABLE_thaw(0, 0, {unknown => {} } ) };
like($@, qr{unknown base class}, "error on unknown base class");
##########################################################
# calling hooks
my($freeze_pre, $freeze_post, $thaw_pre, $thaw_post);
{ no warnings; #ignore spurious "only used once" warnings
*TestClass::STORABLE_freeze_pre = sub { $freeze_pre = 1 };
*TestClass::STORABLE_freeze_post = sub { $freeze_post = 1 };
*TestClass::STORABLE_thaw_pre = sub { $thaw_pre = 1 };
*TestClass::STORABLE_thaw_post = sub { $thaw_post = 1 };
}
Storable::dclone($object);
ok( $freeze_pre, "STORABLE_freeze_pre called");
ok( $freeze_post, "STORABLE_freeze_post called");
ok( $thaw_pre, "STORABLE_thaw_pre called");
ok( $thaw_post, "STORABLE_thaw_post called");
|
