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