Commit | Line | Data |
3f343de7 |
1 | use strict; |
0e3e3555 |
2 | use warnings FATAL => 'all'; |
3f343de7 |
3 | |
4 | { |
5 | package Foo; |
6 | |
7 | sub export { 'export' }; |
8 | sub foo { 'foo' }; |
9 | } |
10 | |
0e3e3555 |
11 | use Test::More; |
12 | use t::common qw( new_dbm ); |
3f343de7 |
13 | |
14 | use_ok( 'DBM::Deep' ); |
15 | |
0e3e3555 |
16 | my $dbm_factory = new_dbm( autobless => 1 ); |
17 | while ( my $dbm_maker = $dbm_factory->() ) { |
18 | { |
19 | my $db = $dbm_maker->(); |
95bbd935 |
20 | |
0e3e3555 |
21 | my $obj = bless { |
22 | a => 1, |
23 | b => [ 1 .. 3 ], |
24 | }, 'Foo'; |
95bbd935 |
25 | |
0e3e3555 |
26 | $db->{blessed} = $obj; |
27 | is( $db->{blessed}{a}, 1 ); |
28 | is( $db->{blessed}{b}[0], 1 ); |
29 | is( $db->{blessed}{b}[1], 2 ); |
30 | is( $db->{blessed}{b}[2], 3 ); |
31 | |
32 | my $obj2 = bless [ |
33 | { a => 'foo' }, |
34 | 2, |
35 | ], 'Foo'; |
36 | $db->{blessed2} = $obj2; |
37 | |
38 | is( $db->{blessed2}[0]{a}, 'foo' ); |
39 | is( $db->{blessed2}[1], '2' ); |
40 | |
41 | $db->{unblessed} = {}; |
42 | $db->{unblessed}{a} = 1; |
43 | $db->{unblessed}{b} = []; |
44 | $db->{unblessed}{b}[0] = 1; |
45 | $db->{unblessed}{b}[1] = 2; |
46 | $db->{unblessed}{b}[2] = 3; |
47 | |
48 | is( $db->{unblessed}{a}, 1 ); |
49 | is( $db->{unblessed}{b}[0], 1 ); |
50 | is( $db->{unblessed}{b}[1], 2 ); |
51 | is( $db->{unblessed}{b}[2], 3 ); |
52 | |
53 | $db->{blessed_long} = bless {}, 'a' x 1000; |
54 | $db->_get_self->_engine->storage->close( $db->_get_self ); |
55 | } |
3f343de7 |
56 | |
0e3e3555 |
57 | { |
58 | my $db = $dbm_maker->(); |
3f343de7 |
59 | |
0e3e3555 |
60 | my $obj = $db->{blessed}; |
61 | isa_ok( $obj, 'Foo' ); |
62 | can_ok( $obj, 'export', 'foo' ); |
63 | ok( !$obj->can( 'STORE' ), "... but it cannot 'STORE'" ); |
30c95847 |
64 | |
0e3e3555 |
65 | is( $obj->{a}, 1 ); |
66 | is( $obj->{b}[0], 1 ); |
67 | is( $obj->{b}[1], 2 ); |
68 | is( $obj->{b}[2], 3 ); |
69 | |
70 | my $obj2 = $db->{blessed2}; |
71 | isa_ok( $obj2, 'Foo' ); |
72 | can_ok( $obj2, 'export', 'foo' ); |
73 | ok( !$obj2->can( 'STORE' ), "... but it cannot 'STORE'" ); |
74 | |
75 | is( $obj2->[0]{a}, 'foo' ); |
76 | is( $obj2->[1], '2' ); |
77 | |
78 | is( $db->{unblessed}{a}, 1 ); |
79 | is( $db->{unblessed}{b}[0], 1 ); |
80 | is( $db->{unblessed}{b}[1], 2 ); |
81 | is( $db->{unblessed}{b}[2], 3 ); |
82 | |
83 | $obj->{c} = 'new'; |
84 | is( $db->{blessed}{c}, 'new' ); |
85 | |
86 | isa_ok( $db->{blessed_long}, 'a' x 1000 ); |
87 | $db->_get_self->_engine->storage->close( $db->_get_self ); |
88 | } |
89 | |
90 | { |
91 | my $db = $dbm_maker->(); |
92 | is( $db->{blessed}{c}, 'new' ); |
93 | |
94 | my $structure = $db->export(); |
95 | use Data::Dumper;print Dumper $structure; |
96 | |
97 | my $obj = $structure->{blessed}; |
98 | isa_ok( $obj, 'Foo' ); |
99 | can_ok( $obj, 'export', 'foo' ); |
100 | ok( !$obj->can( 'STORE' ), "... but it cannot 'STORE'" ); |
101 | |
102 | is( $obj->{a}, 1 ); |
103 | is( $obj->{b}[0], 1 ); |
104 | is( $obj->{b}[1], 2 ); |
105 | is( $obj->{b}[2], 3 ); |
106 | |
107 | my $obj2 = $structure->{blessed2}; |
108 | isa_ok( $obj2, 'Foo' ); |
109 | can_ok( $obj2, 'export', 'foo' ); |
110 | ok( !$obj2->can( 'STORE' ), "... but it cannot 'STORE'" ); |
111 | |
112 | is( $obj2->[0]{a}, 'foo' ); |
113 | is( $obj2->[1], '2' ); |
114 | |
115 | is( $structure->{unblessed}{a}, 1 ); |
116 | is( $structure->{unblessed}{b}[0], 1 ); |
117 | is( $structure->{unblessed}{b}[1], 2 ); |
118 | is( $structure->{unblessed}{b}[2], 3 ); |
119 | $db->_get_self->_engine->storage->close( $db->_get_self ); |
120 | } |
121 | |
122 | { |
123 | my $db = $dbm_maker->( autobless => 0 ); |
124 | |
125 | my $obj = $db->{blessed}; |
126 | isa_ok( $obj, 'DBM::Deep' ); |
127 | can_ok( $obj, 'export', 'STORE' ); |
128 | ok( !$obj->can( 'foo' ), "... but it cannot 'foo'" ); |
129 | |
130 | is( $obj->{a}, 1 ); |
131 | is( $obj->{b}[0], 1 ); |
132 | is( $obj->{b}[1], 2 ); |
133 | is( $obj->{b}[2], 3 ); |
134 | |
135 | my $obj2 = $db->{blessed2}; |
136 | isa_ok( $obj2, 'DBM::Deep' ); |
137 | can_ok( $obj2, 'export', 'STORE' ); |
138 | ok( !$obj2->can( 'foo' ), "... but it cannot 'foo'" ); |
139 | |
140 | is( $obj2->[0]{a}, 'foo' ); |
141 | is( $obj2->[1], '2' ); |
142 | |
143 | is( $db->{unblessed}{a}, 1 ); |
144 | is( $db->{unblessed}{b}[0], 1 ); |
145 | is( $db->{unblessed}{b}[1], 2 ); |
146 | is( $db->{unblessed}{b}[2], 3 ); |
147 | $db->_get_self->_engine->storage->close( $db->_get_self ); |
148 | } |
3f343de7 |
149 | } |
150 | |
0e3e3555 |
151 | $dbm_factory = new_dbm( autobless => 1 ); |
152 | while ( my $dbm_maker = $dbm_factory->() ) { |
2120a181 |
153 | { |
0e3e3555 |
154 | my $db = $dbm_maker->(); |
2120a181 |
155 | my $obj = bless { |
156 | a => 1, |
157 | b => [ 1 .. 3 ], |
158 | }, 'Foo'; |
159 | |
160 | $db->import( { blessed => $obj } ); |
161 | } |
162 | |
163 | { |
0e3e3555 |
164 | my $db = $dbm_maker->(); |
2120a181 |
165 | |
166 | my $blessed = $db->{blessed}; |
167 | isa_ok( $blessed, 'Foo' ); |
168 | is( $blessed->{a}, 1 ); |
169 | } |
9cb06093 |
170 | } |
70d0fb51 |
171 | |
0e3e3555 |
172 | # test blessing hash into short named class (Foo), then re-blessing into |
173 | # longer named class (FooFoo) and replacing key in db file, then validating |
174 | # content after that point in file to check for corruption. |
175 | $dbm_factory = new_dbm( autobless => 1 ); |
176 | while ( my $dbm_maker = $dbm_factory->() ) { |
177 | my $db = $dbm_maker->(); |
70d0fb51 |
178 | |
179 | my $obj = bless {}, 'Foo'; |
180 | |
181 | $db->{blessed} = $obj; |
182 | $db->{after} = "hello"; |
45f047f8 |
183 | |
70d0fb51 |
184 | my $obj2 = bless {}, 'FooFoo'; |
45f047f8 |
185 | |
70d0fb51 |
186 | $db->{blessed} = $obj2; |
187 | |
188 | is( $db->{after}, "hello" ); |
189 | } |
0e3e3555 |
190 | |
191 | done_testing; |