r8208@rob-kinyons-computer-2 (orig r10033): rkinyon | 2007-10-01 11:17:40 -0400
[dbsrgits/DBM-Deep.git] / t / 17_import.t
CommitLineData
ffed8b01 1##
2# DBM::Deep Test
3##
4use strict;
2120a181 5use Test::More tests => 11;
a3e62809 6use Test::Deep;
fde3db1a 7use t::common qw( new_fh );
ffed8b01 8
9use_ok( 'DBM::Deep' );
10
2120a181 11{
12 my ($fh, $filename) = new_fh();
13 my $db = DBM::Deep->new({
14 file => $filename,
15 autobless => 1,
16 });
ffed8b01 17
18##
19# Create structure in memory
20##
2120a181 21 my $struct = {
22 key1 => "value1",
23 key2 => "value2",
24 array1 => [ "elem0", "elem1", "elem2" ],
a3e62809 25 hash1 => {
26 subkey1 => "subvalue1",
27 subkey2 => "subvalue2",
2120a181 28 subkey3 => bless( {}, 'Foo' ),
29 }
30 };
31
32 $db->import( $struct );
33
34 cmp_deeply(
35 $db,
36 noclass({
37 key1 => 'value1',
38 key2 => 'value2',
39 array1 => [ 'elem0', 'elem1', 'elem2', ],
40 hash1 => {
41 subkey1 => "subvalue1",
42 subkey2 => "subvalue2",
43 subkey3 => useclass( bless {}, 'Foo' ),
44 },
45 }),
46 "Everything matches",
47 );
48
49 $struct->{foo} = 'bar';
50 is( $struct->{foo}, 'bar', "\$struct has foo and it's 'bar'" );
51 ok( !exists $db->{foo}, "\$db doesn't have the 'foo' key, so \$struct is not tied" );
52
53 $struct->{hash1}->{foo} = 'bar';
54 is( $struct->{hash1}->{foo}, 'bar', "\$struct->{hash1} has foo and it's 'bar'" );
55 ok( !exists $db->{hash1}->{foo}, "\$db->{hash1} doesn't have the 'foo' key, so \$struct->{hash1} is not tied" );
56}
57
58{
807f63a7 59 diag "\nThere seems to be a bug in Clone on Perl 5.9+ that is causing\nthese tests to fail."
60 if $] >= 5.009;
61
2120a181 62 my ($fh, $filename) = new_fh();
63 my $db = DBM::Deep->new({
64 file => $filename,
65 type => DBM::Deep->TYPE_ARRAY,
66 });
67
68 my $struct = [
69 1 .. 3,
70 [ 2, 4, 6 ],
71 bless( [], 'Bar' ),
72 { foo => [ 2 .. 4 ] },
73 ];
74
75 $db->import( $struct );
76
77 cmp_deeply(
78 $db,
79 noclass([
80 1 .. 3,
81 [ 2, 4, 6 ],
82 useclass( bless( [], 'Bar' ) ),
83 { foo => [ 2 .. 4 ] },
84 ]),
85 "Everything matches",
86 );
87
88 push @$struct, 'bar';
89 is( $struct->[-1], 'bar', "\$struct has 'bar' at the end" );
90 ok( $db->[-1], "\$db doesn't have the 'bar' value at the end, so \$struct is not tied" );
91}
92
93# Failure case to verify that rollback occurs
94{
95 my ($fh, $filename) = new_fh();
96 my $db = DBM::Deep->new({
97 file => $filename,
98 autobless => 1,
99 });
100
101 $db->{foo} = 'bar';
102
103 my $x;
104 my $struct = {
105 key1 => [
106 2, \$x, 3,
107 ],
108 };
109
110 eval {
111 $db->import( $struct );
112 };
113 like( $@, qr/Storage of references of type 'SCALAR' is not supported/, 'Error message correct' );
114
e9b0b5f0 115 TODO: {
116 local $TODO = "Importing cannot occur within a transaction yet.";
117 cmp_deeply(
118 $db,
119 noclass({
120 foo => 'bar',
121 }),
122 "Everything matches",
123 );
124 }
2120a181 125}
12b96196 126
127__END__
128
129Need to add tests for:
130 - Failure case (have something tied or a glob or something like that)
131 - Where we already have $db->{hash1} to make sure that it's not overwritten