2 use warnings FATAL => 'all';
7 sub export { 'export' };
12 use t::common qw( new_dbm );
14 use_ok( 'DBM::Deep' );
16 my $dbm_factory = new_dbm( autobless => 1 );
17 while ( my $dbm_maker = $dbm_factory->() ) {
19 my $db = $dbm_maker->();
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 );
36 $db->{blessed2} = $obj2;
38 is( $db->{blessed2}[0]{a}, 'foo' );
39 is( $db->{blessed2}[1], '2' );
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;
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 );
53 $db->{blessed_long} = bless {}, 'a' x 1000;
54 $db->_get_self->_engine->storage->close( $db->_get_self );
58 my $db = $dbm_maker->();
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'" );
66 is( $obj->{b}[0], 1 );
67 is( $obj->{b}[1], 2 );
68 is( $obj->{b}[2], 3 );
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'" );
75 is( $obj2->[0]{a}, 'foo' );
76 is( $obj2->[1], '2' );
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 );
84 is( $db->{blessed}{c}, 'new' );
86 isa_ok( $db->{blessed_long}, 'a' x 1000 );
87 $db->_get_self->_engine->storage->close( $db->_get_self );
91 my $db = $dbm_maker->();
92 is( $db->{blessed}{c}, 'new' );
94 my $structure = $db->export();
95 use Data::Dumper;print Dumper $structure;
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'" );
103 is( $obj->{b}[0], 1 );
104 is( $obj->{b}[1], 2 );
105 is( $obj->{b}[2], 3 );
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'" );
112 is( $obj2->[0]{a}, 'foo' );
113 is( $obj2->[1], '2' );
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 );
123 my $db = $dbm_maker->( autobless => 0 );
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'" );
131 is( $obj->{b}[0], 1 );
132 is( $obj->{b}[1], 2 );
133 is( $obj->{b}[2], 3 );
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'" );
140 is( $obj2->[0]{a}, 'foo' );
141 is( $obj2->[1], '2' );
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 );
151 $dbm_factory = new_dbm( autobless => 1 );
152 while ( my $dbm_maker = $dbm_factory->() ) {
154 my $db = $dbm_maker->();
160 $db->import( { blessed => $obj } );
164 my $db = $dbm_maker->();
166 my $blessed = $db->{blessed};
167 isa_ok( $blessed, 'Foo' );
168 is( $blessed->{a}, 1 );
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->();
179 my $obj = bless {}, 'Foo';
181 $db->{blessed} = $obj;
182 $db->{after} = "hello";
184 my $obj2 = bless {}, 'FooFoo';
186 $db->{blessed} = $obj2;
188 is( $db->{after}, "hello" );