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