6 sub export { 'export' };
10 use Test::More tests => 65;
11 use t::common qw( new_fh );
13 use_ok( 'DBM::Deep' );
15 my ($fh, $filename) = new_fh();
17 my $db = DBM::Deep->new(
27 $db->{blessed} = $obj;
28 is( $db->{blessed}{a}, 1 );
29 is( $db->{blessed}{b}[0], 1 );
30 is( $db->{blessed}{b}[1], 2 );
31 is( $db->{blessed}{b}[2], 3 );
37 $db->{blessed2} = $obj2;
39 is( $db->{blessed2}[0]{a}, 'foo' );
40 is( $db->{blessed2}[1], '2' );
42 $db->{unblessed} = {};
43 $db->{unblessed}{a} = 1;
44 $db->{unblessed}{b} = [];
45 $db->{unblessed}{b}[0] = 1;
46 $db->{unblessed}{b}[1] = 2;
47 $db->{unblessed}{b}[2] = 3;
49 is( $db->{unblessed}{a}, 1 );
50 is( $db->{unblessed}{b}[0], 1 );
51 is( $db->{unblessed}{b}[1], 2 );
52 is( $db->{unblessed}{b}[2], 3 );
54 $db->{blessed_long} = bless {}, 'a' x 1000;
58 my $db = DBM::Deep->new(
63 my $obj = $db->{blessed};
64 isa_ok( $obj, 'Foo' );
65 can_ok( $obj, 'export', 'foo' );
66 ok( !$obj->can( 'STORE' ), "... but it cannot 'STORE'" );
69 is( $obj->{b}[0], 1 );
70 is( $obj->{b}[1], 2 );
71 is( $obj->{b}[2], 3 );
73 my $obj2 = $db->{blessed2};
74 isa_ok( $obj2, 'Foo' );
75 can_ok( $obj2, 'export', 'foo' );
76 ok( !$obj2->can( 'STORE' ), "... but it cannot 'STORE'" );
78 is( $obj2->[0]{a}, 'foo' );
79 is( $obj2->[1], '2' );
81 is( $db->{unblessed}{a}, 1 );
82 is( $db->{unblessed}{b}[0], 1 );
83 is( $db->{unblessed}{b}[1], 2 );
84 is( $db->{unblessed}{b}[2], 3 );
87 is( $db->{blessed}{c}, 'new' );
89 isa_ok( $db->{blessed_long}, 'a' x 1000 );
93 my $db = DBM::Deep->new(
97 is( $db->{blessed}{c}, 'new' );
99 my $structure = $db->export();
100 use Data::Dumper;print Dumper $structure;
102 my $obj = $structure->{blessed};
103 isa_ok( $obj, 'Foo' );
104 can_ok( $obj, 'export', 'foo' );
105 ok( !$obj->can( 'STORE' ), "... but it cannot 'STORE'" );
108 is( $obj->{b}[0], 1 );
109 is( $obj->{b}[1], 2 );
110 is( $obj->{b}[2], 3 );
112 my $obj2 = $structure->{blessed2};
113 isa_ok( $obj2, 'Foo' );
114 can_ok( $obj2, 'export', 'foo' );
115 ok( !$obj2->can( 'STORE' ), "... but it cannot 'STORE'" );
117 is( $obj2->[0]{a}, 'foo' );
118 is( $obj2->[1], '2' );
120 is( $structure->{unblessed}{a}, 1 );
121 is( $structure->{unblessed}{b}[0], 1 );
122 is( $structure->{unblessed}{b}[1], 2 );
123 is( $structure->{unblessed}{b}[2], 3 );
127 my $db = DBM::Deep->new(
132 my $obj = $db->{blessed};
133 isa_ok( $obj, 'DBM::Deep' );
134 can_ok( $obj, 'export', 'STORE' );
135 ok( !$obj->can( 'foo' ), "... but it cannot 'foo'" );
138 is( $obj->{b}[0], 1 );
139 is( $obj->{b}[1], 2 );
140 is( $obj->{b}[2], 3 );
142 my $obj2 = $db->{blessed2};
143 isa_ok( $obj2, 'DBM::Deep' );
144 can_ok( $obj2, 'export', 'STORE' );
145 ok( !$obj2->can( 'foo' ), "... but it cannot 'foo'" );
147 is( $obj2->[0]{a}, 'foo' );
148 is( $obj2->[1], '2' );
150 is( $db->{unblessed}{a}, 1 );
151 is( $db->{unblessed}{b}[0], 1 );
152 is( $db->{unblessed}{b}[1], 2 );
153 is( $db->{unblessed}{b}[2], 3 );
157 my ($fh2, $filename2) = new_fh();
159 my $db = DBM::Deep->new(
168 $db->import( { blessed => $obj } );
172 my $db = DBM::Deep->new(
177 my $blessed = $db->{blessed};
178 isa_ok( $blessed, 'Foo' );
179 is( $blessed->{a}, 1 );
185 # test blessing hash into short named class (Foo), then re-blessing into
186 # longer named class (FooFoo) and replacing key in db file, then validating
187 # content after that point in file to check for corruption.
189 my ($fh3, $filename3) = new_fh();
190 my $db = DBM::Deep->new(
195 my $obj = bless {}, 'Foo';
197 $db->{blessed} = $obj;
198 $db->{after} = "hello";
200 my $obj2 = bless {}, 'FooFoo';
202 $db->{blessed} = $obj2;
204 is( $db->{after}, "hello" );