r12194@rob-kinyons-computer-2 (orig r10513): rkinyon | 2008-01-10 23:43:55 -0500
[dbsrgits/DBM-Deep.git] / t / 17_import.t
CommitLineData
ffed8b01 1##
2# DBM::Deep Test
3##
4use strict;
e00d0eb3 5use Test::More tests => 17;
a3e62809 6use Test::Deep;
e00d0eb3 7use Test::Exception;
fde3db1a 8use t::common qw( new_fh );
ffed8b01 9
10use_ok( 'DBM::Deep' );
11
e00d0eb3 12# Failure cases to make sure that things are caught right.
13foreach my $type ( DBM::Deep->TYPE_HASH, DBM::Deep->TYPE_ARRAY ) {
14 my ($fh, $filename) = new_fh();
15 my $db = DBM::Deep->new({
16 file => $filename,
17 type => $type,
18 });
19
20 # Load a scalar
21 throws_ok {
22 $db->import( 'foo' );
23 } qr/Cannot import a scalar/, "Importing a scalar to type '$type' fails";
24
25 # Load a ref of the wrong type
26 # Load something with bad stuff in it
27 my $x = 3;
28 if ( $type eq 'A' ) {
29 throws_ok {
30 $db->import( { foo => 'bar' } );
31 } qr/Cannot import a hash into an array/, "Wrong type fails";
32
33 throws_ok {
34 $db->import( [ \$x ] );
35 } qr/Storage of references of type 'SCALAR' is not supported/, "Bad stuff fails";
36 }
37 else {
38 throws_ok {
39 $db->import( [ 1 .. 3 ] );
40 } qr/Cannot import an array into a hash/, "Wrong type fails";
41
42 throws_ok {
43 $db->import( { foo => \$x } );
44 } qr/Storage of references of type 'SCALAR' is not supported/, "Bad stuff fails";
45 }
46}
47
2120a181 48{
49 my ($fh, $filename) = new_fh();
50 my $db = DBM::Deep->new({
51 file => $filename,
52 autobless => 1,
53 });
ffed8b01 54
55##
56# Create structure in memory
57##
2120a181 58 my $struct = {
59 key1 => "value1",
60 key2 => "value2",
61 array1 => [ "elem0", "elem1", "elem2" ],
a3e62809 62 hash1 => {
63 subkey1 => "subvalue1",
64 subkey2 => "subvalue2",
e00d0eb3 65 subkey3 => bless( { a => 'b' }, 'Foo' ),
2120a181 66 }
67 };
68
69 $db->import( $struct );
70
71 cmp_deeply(
72 $db,
73 noclass({
74 key1 => 'value1',
75 key2 => 'value2',
76 array1 => [ 'elem0', 'elem1', 'elem2', ],
77 hash1 => {
78 subkey1 => "subvalue1",
79 subkey2 => "subvalue2",
e00d0eb3 80 subkey3 => useclass( bless { a => 'b' }, 'Foo' ),
2120a181 81 },
82 }),
83 "Everything matches",
84 );
85
86 $struct->{foo} = 'bar';
87 is( $struct->{foo}, 'bar', "\$struct has foo and it's 'bar'" );
88 ok( !exists $db->{foo}, "\$db doesn't have the 'foo' key, so \$struct is not tied" );
89
90 $struct->{hash1}->{foo} = 'bar';
91 is( $struct->{hash1}->{foo}, 'bar', "\$struct->{hash1} has foo and it's 'bar'" );
92 ok( !exists $db->{hash1}->{foo}, "\$db->{hash1} doesn't have the 'foo' key, so \$struct->{hash1} is not tied" );
93}
94
95{
96 my ($fh, $filename) = new_fh();
97 my $db = DBM::Deep->new({
98 file => $filename,
99 type => DBM::Deep->TYPE_ARRAY,
100 });
101
102 my $struct = [
103 1 .. 3,
104 [ 2, 4, 6 ],
105 bless( [], 'Bar' ),
106 { foo => [ 2 .. 4 ] },
107 ];
108
109 $db->import( $struct );
110
111 cmp_deeply(
112 $db,
113 noclass([
114 1 .. 3,
115 [ 2, 4, 6 ],
116 useclass( bless( [], 'Bar' ) ),
117 { foo => [ 2 .. 4 ] },
118 ]),
119 "Everything matches",
120 );
121
122 push @$struct, 'bar';
123 is( $struct->[-1], 'bar', "\$struct has 'bar' at the end" );
124 ok( $db->[-1], "\$db doesn't have the 'bar' value at the end, so \$struct is not tied" );
125}
126
127# Failure case to verify that rollback occurs
128{
129 my ($fh, $filename) = new_fh();
130 my $db = DBM::Deep->new({
131 file => $filename,
132 autobless => 1,
133 });
134
135 $db->{foo} = 'bar';
136
137 my $x;
138 my $struct = {
139 key1 => [
140 2, \$x, 3,
141 ],
142 };
143
144 eval {
145 $db->import( $struct );
146 };
147 like( $@, qr/Storage of references of type 'SCALAR' is not supported/, 'Error message correct' );
148
e9b0b5f0 149 TODO: {
150 local $TODO = "Importing cannot occur within a transaction yet.";
151 cmp_deeply(
152 $db,
153 noclass({
154 foo => 'bar',
155 }),
156 "Everything matches",
157 );
158 }
2120a181 159}
12b96196 160
161__END__
162
163Need to add tests for:
164 - Failure case (have something tied or a glob or something like that)
165 - Where we already have $db->{hash1} to make sure that it's not overwritten