r6127@000-443-371 (orig r9960): rkinyon | 2007-09-20 21:13:08 -0400
[dbsrgits/DBM-Deep.git] / t / 17_import.t
1 ##
2 # DBM::Deep Test
3 ##
4 use strict;
5 use Test::More tests => 11;
6 use Test::Deep;
7 use t::common qw( new_fh );
8
9 use_ok( 'DBM::Deep' );
10
11 {
12     my ($fh, $filename) = new_fh();
13     my $db = DBM::Deep->new({
14         file      => $filename,
15         autobless => 1,
16     });
17
18 ##
19 # Create structure in memory
20 ##
21     my $struct = {
22         key1 => "value1",
23         key2 => "value2",
24         array1 => [ "elem0", "elem1", "elem2" ],
25         hash1 => {
26             subkey1 => "subvalue1",
27             subkey2 => "subvalue2",
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 {
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
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
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     }
125 }
126
127 __END__
128
129 Need 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