6 sub export { 'export' };
10 use Test::More tests => 64;
11 use File::Temp qw( tempfile tempdir );
12 use Fcntl qw( :flock );
14 use_ok( 'DBM::Deep' );
16 my $dir = tempdir( CLEANUP => 1 );
17 my ($fh, $filename) = tempfile( 'tmpXXXX', UNLINK => 1, DIR => $dir );
20 my $db = DBM::Deep->new(
30 $db->{blessed} = $obj;
31 is( $db->{blessed}{a}, 1 );
32 is( $db->{blessed}{b}[0], 1 );
33 is( $db->{blessed}{b}[1], 2 );
34 is( $db->{blessed}{b}[2], 3 );
40 $db->{blessed2} = $obj2;
42 is( $db->{blessed2}[0]{a}, 'foo' );
43 is( $db->{blessed2}[1], '2' );
45 $db->{unblessed} = {};
46 $db->{unblessed}{a} = 1;
47 $db->{unblessed}{b} = [];
48 $db->{unblessed}{b}[0] = 1;
49 $db->{unblessed}{b}[1] = 2;
50 $db->{unblessed}{b}[2] = 3;
52 is( $db->{unblessed}{a}, 1 );
53 is( $db->{unblessed}{b}[0], 1 );
54 is( $db->{unblessed}{b}[1], 2 );
55 is( $db->{unblessed}{b}[2], 3 );
59 my $db = DBM::Deep->new(
64 my $obj = $db->{blessed};
65 isa_ok( $obj, 'Foo' );
66 can_ok( $obj, 'export', 'foo' );
67 ok( !$obj->can( 'STORE' ), "... but it cannot 'STORE'" );
70 is( $obj->{b}[0], 1 );
71 is( $obj->{b}[1], 2 );
72 is( $obj->{b}[2], 3 );
74 my $obj2 = $db->{blessed2};
75 isa_ok( $obj, 'Foo' );
76 can_ok( $obj, 'export', 'foo' );
77 ok( !$obj->can( 'STORE' ), "... but it cannot 'STORE'" );
79 is( $obj2->[0]{a}, 'foo' );
80 is( $obj2->[1], '2' );
82 is( $db->{unblessed}{a}, 1 );
83 is( $db->{unblessed}{b}[0], 1 );
84 is( $db->{unblessed}{b}[1], 2 );
85 is( $db->{unblessed}{b}[2], 3 );
88 is( $db->{blessed}{c}, 'new' );
92 my $db = DBM::Deep->new(
96 is( $db->{blessed}{c}, 'new' );
98 my $structure = $db->export();
100 my $obj = $structure->{blessed};
101 isa_ok( $obj, 'Foo' );
102 can_ok( $obj, 'export', 'foo' );
103 ok( !$obj->can( 'STORE' ), "... but it cannot 'STORE'" );
106 is( $obj->{b}[0], 1 );
107 is( $obj->{b}[1], 2 );
108 is( $obj->{b}[2], 3 );
110 my $obj2 = $structure->{blessed2};
111 isa_ok( $obj, 'Foo' );
112 can_ok( $obj, 'export', 'foo' );
113 ok( !$obj->can( 'STORE' ), "... but it cannot 'STORE'" );
115 is( $obj2->[0]{a}, 'foo' );
116 is( $obj2->[1], '2' );
118 is( $structure->{unblessed}{a}, 1 );
119 is( $structure->{unblessed}{b}[0], 1 );
120 is( $structure->{unblessed}{b}[1], 2 );
121 is( $structure->{unblessed}{b}[2], 3 );
125 my $db = DBM::Deep->new(
129 my $obj = $db->{blessed};
130 isa_ok( $obj, 'DBM::Deep' );
131 can_ok( $obj, 'export', 'STORE' );
132 ok( !$obj->can( 'foo' ), "... but it cannot 'foo'" );
135 is( $obj->{b}[0], 1 );
136 is( $obj->{b}[1], 2 );
137 is( $obj->{b}[2], 3 );
139 my $obj2 = $db->{blessed2};
140 isa_ok( $obj2, 'DBM::Deep' );
141 can_ok( $obj2, 'export', 'STORE' );
142 ok( !$obj2->can( 'foo' ), "... but it cannot 'foo'" );
144 is( $obj2->[0]{a}, 'foo' );
145 is( $obj2->[1], '2' );
147 is( $db->{unblessed}{a}, 1 );
148 is( $db->{unblessed}{b}[0], 1 );
149 is( $db->{unblessed}{b}[1], 2 );
150 is( $db->{unblessed}{b}[2], 3 );
153 my ($fh2, $filename2) = tempfile( 'tmpXXXX', UNLINK => 1, DIR => $dir );
156 my $db = DBM::Deep->new(
165 $db->import( { blessed => $obj } );
169 my $db = DBM::Deep->new(
174 my $blessed = $db->{blessed};
175 isa_ok( $blessed, 'Foo' );
176 is( $blessed->{a}, 1 );
181 # test blessing hash into short named class (Foo), then re-blessing into
182 # longer named class (FooFoo) and replacing key in db file, then validating
183 # content after that point in file to check for corruption.
185 my ($fh3, $filename3) = tempfile( 'tmpXXXX', UNLINK => 1, DIR => $dir );
187 my $db = DBM::Deep->new(
192 my $obj = bless {}, 'Foo';
194 $db->{blessed} = $obj;
195 $db->{after} = "hello";
197 my $obj2 = bless {}, 'FooFoo';
199 $db->{blessed} = $obj2;
201 is( $db->{after}, "hello" );