2 use warnings FATAL => 'all';
7 use t::common qw( new_dbm );
11 # Failure cases to make sure that things are caught right.
12 foreach my $type ( DBM::Deep->TYPE_HASH, DBM::Deep->TYPE_ARRAY ) {
13 my $dbm_factory = new_dbm( type => $type );
14 while ( my $dbm_maker = $dbm_factory->() ) {
15 my $db = $dbm_maker->();
20 } qr/Cannot import a scalar/, "Importing a scalar to type '$type' fails";
22 # Load a ref of the wrong type
23 # Load something with bad stuff in it
27 $db->import( { foo => 'bar' } );
28 } qr/Cannot import a hash into an array/, "Wrong type fails";
31 $db->import( [ \$x ] );
32 } qr/Storage of references of type 'SCALAR' is not supported/, "Bad stuff fails";
36 $db->import( [ 1 .. 3 ] );
37 } qr/Cannot import an array into a hash/, "Wrong type fails";
40 $db->import( { foo => \$x } );
41 } qr/Storage of references of type 'SCALAR' is not supported/, "Bad stuff fails";
46 my $dbm_factory = new_dbm( autobless => 1 );
47 while ( my $dbm_maker = $dbm_factory->() ) {
48 my $db = $dbm_maker->();
51 # Create structure in memory
56 array1 => [ "elem0", "elem1", "elem2" ],
58 subkey1 => "subvalue1",
59 subkey2 => "subvalue2",
60 subkey3 => bless( { a => 'b' }, 'Foo' ),
64 $db->import( $struct );
71 array1 => [ 'elem0', 'elem1', 'elem2', ],
73 subkey1 => "subvalue1",
74 subkey2 => "subvalue2",
75 subkey3 => useclass( bless { a => 'b' }, 'Foo' ),
81 $struct->{foo} = 'bar';
82 is( $struct->{foo}, 'bar', "\$struct has foo and it's 'bar'" );
83 ok( !exists $db->{foo}, "\$db doesn't have the 'foo' key, so \$struct is not tied" );
85 $struct->{hash1}->{foo} = 'bar';
86 is( $struct->{hash1}->{foo}, 'bar', "\$struct->{hash1} has foo and it's 'bar'" );
87 ok( !exists $db->{hash1}->{foo}, "\$db->{hash1} doesn't have the 'foo' key, so \$struct->{hash1} is not tied" );
90 $dbm_factory = new_dbm( type => DBM::Deep->TYPE_ARRAY );
91 while ( my $dbm_maker = $dbm_factory->() ) {
92 my $db = $dbm_maker->();
98 { foo => [ 2 .. 4 ] },
101 $db->import( $struct );
108 useclass( bless( [], 'Bar' ) ),
109 { foo => [ 2 .. 4 ] },
111 "Everything matches",
114 push @$struct, 'bar';
115 is( $struct->[-1], 'bar', "\$struct has 'bar' at the end" );
116 ok( $db->[-1], "\$db doesn't have the 'bar' value at the end, so \$struct is not tied" );
119 # Failure case to verify that rollback occurs
120 $dbm_factory = new_dbm( autobless => 1 );
121 while ( my $dbm_maker = $dbm_factory->() ) {
122 my $db = $dbm_maker->();
134 $db->import( $struct );
136 like( $@, qr/Storage of references of type 'SCALAR' is not supported/, 'Error message correct' );
139 local $TODO = "Importing cannot occur within a transaction yet.";
145 "Everything matches",
154 Need to add tests for:
155 - Failure case (have something tied or a glob or something like that)
156 - Where we already have $db->{hash1} to make sure that it's not overwritten