Added test for special case where hash is stored blessed into class with short name...
[dbsrgits/DBM-Deep.git] / t / 24_autobless.t
1 use strict;
2
3 {
4     package Foo;
5
6     sub export { 'export' };
7     sub foo { 'foo' };
8 }
9
10 use Test::More tests => 29;
11
12 use_ok( 'DBM::Deep' );
13
14 unlink 't/test.db';
15 my $db = DBM::Deep->new(
16     file     => "t/test.db",
17     autobless => 1,
18 );
19 if ($db->error()) {
20         die "ERROR: " . $db->error();
21 }
22
23 my $obj = bless {
24     a => 1,
25     b => [ 1 .. 3 ],
26 }, 'Foo';
27
28 $db->{blessed} = $obj;
29
30 $db->{unblessed} = {};
31 $db->{unblessed}{a} = 1;
32 $db->{unblessed}{b} = [];
33 $db->{unblessed}{b}[0] = 1;
34 $db->{unblessed}{b}[1] = 2;
35 $db->{unblessed}{b}[2] = 3;
36
37 undef $db;
38
39 my $db2 = DBM::Deep->new(
40     file     => 't/test.db',
41     autobless => 1,
42 );
43 if ($db2->error()) {
44         die "ERROR: " . $db2->error();
45 }
46
47 my $obj2 = $db2->{blessed};
48 isa_ok( $obj2, 'Foo' );
49 can_ok( $obj2, 'export', 'foo' );
50 ok( !$obj2->can( 'STORE' ), "... but it cannot 'STORE'" );
51
52 is( $obj2->{a}, 1 );
53 is( $obj2->{b}[0], 1 );
54 is( $obj2->{b}[1], 2 );
55 is( $obj2->{b}[2], 3 );
56
57 is( $db2->{unblessed}{a}, 1 );
58 is( $db2->{unblessed}{b}[0], 1 );
59 is( $db2->{unblessed}{b}[1], 2 );
60 is( $db2->{unblessed}{b}[2], 3 );
61
62 $obj2->{c} = 'new';
63 is( $db2->{blessed}{c}, 'new' );
64
65 undef $db2;
66
67 $db2 = DBM::Deep->new(
68     file     => 't/test.db',
69     autobless => 1,
70 );
71 is( $db2->{blessed}{c}, 'new' );
72
73 TODO: {
74     todo_skip "_copy_node() doesn't work with autobless", 1;
75     my $structure = $db2->export();
76     ok( 1 );
77 }
78
79 my $db3 = DBM::Deep->new(
80     file     => 't/test.db',
81 );
82 if ($db3->error()) {
83         die "ERROR: " . $db3->error();
84 }
85
86 my $obj3 = $db3->{blessed};
87 isa_ok( $obj3, 'DBM::Deep' );
88 can_ok( $obj3, 'export', 'STORE' );
89 ok( !$obj3->can( 'foo' ), "... but it cannot 'foo'" );
90
91 is( $obj3->{a}, 1 );
92 is( $obj3->{b}[0], 1 );
93 is( $obj3->{b}[1], 2 );
94 is( $obj3->{b}[2], 3 );
95
96 is( $db3->{unblessed}{a}, 1 );
97 is( $db3->{unblessed}{b}[0], 1 );
98 is( $db3->{unblessed}{b}[1], 2 );
99 is( $db3->{unblessed}{b}[2], 3 );
100
101 undef $db;
102 undef $db2;
103 undef $db3;
104
105 {
106     unlink 't/test.db';
107     my $db = DBM::Deep->new(
108         file     => "t/test.db",
109         autobless => 1,
110     );
111     if ($db->error()) {
112         die "ERROR: " . $db->error();
113     }
114
115     my $obj = bless {
116         a => 1,
117         b => [ 1 .. 3 ],
118     }, 'Foo';
119
120     $db->import( { blessed => $obj } );
121
122     undef $db;
123
124     $db = DBM::Deep->new(
125         file     => "t/test.db",
126         autobless => 1,
127     );
128     if ($db->error()) {
129         die "ERROR: " . $db->error();
130     }
131
132     my $blessed = $db->{blessed};
133     isa_ok( $blessed, 'Foo' );
134     is( $blessed->{a}, 1 );
135 }
136
137 {
138         ##
139         # test blessing hash into short named class (Foo), then re-blessing into
140         # longer named class (FooFoo) and replacing key in db file, then validating
141         # content after that point in file to check for corruption.
142         ##
143     unlink 't/test.db';
144     my $db = DBM::Deep->new(
145         file     => "t/test.db",
146         autobless => 1,
147     );
148     if ($db->error()) {
149         die "ERROR: " . $db->error();
150     }
151
152     my $obj = bless {}, 'Foo';
153
154     $db->{blessed} = $obj;
155     $db->{after} = "hello";
156     
157     my $obj2 = bless {}, 'FooFoo';
158     
159     $db->{blessed} = $obj2;
160
161     is( $db->{after}, "hello" );
162 }
163