Commit | Line | Data |
ffed8b01 |
1 | ## |
2 | # DBM::Deep Test |
3 | ## |
4 | use strict; |
4301e879 |
5 | use Test::More tests => 17; |
a3e62809 |
6 | use Test::Deep; |
4301e879 |
7 | use Test::Exception; |
fde3db1a |
8 | use t::common qw( new_fh ); |
ffed8b01 |
9 | |
10 | use_ok( 'DBM::Deep' ); |
11 | |
4301e879 |
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, |
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 | |
9a63e1f2 |
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 | ## |
9a63e1f2 |
58 | my $struct = { |
59 | key1 => "value1", |
60 | key2 => "value2", |
61 | array1 => [ "elem0", "elem1", "elem2" ], |
a3e62809 |
62 | hash1 => { |
63 | subkey1 => "subvalue1", |
64 | subkey2 => "subvalue2", |
4301e879 |
65 | subkey3 => bless( { a => 'b' }, 'Foo' ), |
9a63e1f2 |
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", |
4301e879 |
80 | subkey3 => useclass( bless { a => 'b' }, 'Foo' ), |
9a63e1f2 |
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 | { |
67c27827 |
96 | diag "\nThere seems to be a bug in Clone on Perl 5.9+ that is causing\nthese tests to fail." |
97 | if $] >= 5.009; |
98 | |
9a63e1f2 |
99 | my ($fh, $filename) = new_fh(); |
100 | my $db = DBM::Deep->new({ |
101 | file => $filename, |
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, |
135 | autobless => 1, |
136 | }); |
137 | |
138 | $db->{foo} = 'bar'; |
139 | |
b48ae6ec |
140 | my $x; |
9a63e1f2 |
141 | my $struct = { |
142 | key1 => [ |
b48ae6ec |
143 | 2, \$x, 3, |
9a63e1f2 |
144 | ], |
145 | }; |
146 | |
147 | eval { |
148 | $db->import( $struct ); |
149 | }; |
b48ae6ec |
150 | like( $@, qr/Storage of references of type 'SCALAR' is not supported/, 'Error message correct' ); |
9a63e1f2 |
151 | |
f72b2dfb |
152 | TODO: { |
153 | local $TODO = "Importing cannot occur within a transaction yet."; |
154 | cmp_deeply( |
155 | $db, |
156 | noclass({ |
157 | foo => 'bar', |
158 | }), |
159 | "Everything matches", |
160 | ); |
161 | } |
9a63e1f2 |
162 | } |
12b96196 |
163 | |
164 | __END__ |
165 | |
166 | Need to add tests for: |
167 | - Failure case (have something tied or a glob or something like that) |
168 | - Where we already have $db->{hash1} to make sure that it's not overwritten |