t/17_import.t

   1 ##
   2 # DBM::Deep Test
   3 ##
   4 use strict;
   5 use Test::More tests => 17;
   6 use Test::Deep;
   7 use Test::Exception;
   8 use t::common qw( new_fh );
   9
  10 use_ok( 'DBM::Deep' );
  11
  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         fh => $fh,
  18         type => $type,
  19     });
  20
  21     # Load a scalar
  22     throws_ok {
  23         $db->import( 'foo' );
  24     } qr/Cannot import a scalar/, "Importing a scalar to type '$type' fails";
  25
  26     # Load a ref of the wrong type
  27     # Load something with bad stuff in it
  28     my $x = 3;
  29     if ( $type eq 'A' ) {
  30         throws_ok {
  31             $db->import( { foo => 'bar' } );
  32         } qr/Cannot import a hash into an array/, "Wrong type fails";
  33
  34         throws_ok {
  35             $db->import( [ \$x ] );
  36         } qr/Storage of references of type 'SCALAR' is not supported/, "Bad stuff fails";
  37     }
  38     else {
  39         throws_ok {
  40             $db->import( [ 1 .. 3 ] );
  41         } qr/Cannot import an array into a hash/, "Wrong type fails";
  42
  43         throws_ok {
  44             $db->import( { foo => \$x } );
  45         } qr/Storage of references of type 'SCALAR' is not supported/, "Bad stuff fails";
  46     }
  47 }
  48
  49 {
  50     my ($fh, $filename) = new_fh();
  51     my $db = DBM::Deep->new({
  52         file      => $filename,
  53         fh => $fh,
  54         autobless => 1,
  55     });
  56
  57 ##
  58 # Create structure in memory
  59 ##
  60     my $struct = {
  61         key1 => "value1",
  62         key2 => "value2",
  63         array1 => [ "elem0", "elem1", "elem2" ],
  64         hash1 => {
  65             subkey1 => "subvalue1",
  66             subkey2 => "subvalue2",
  67             subkey3 => bless( { a => 'b' }, 'Foo' ),
  68         }
  69     };
  70
  71     $db->import( $struct );
  72
  73     cmp_deeply(
  74         $db,
  75         noclass({
  76             key1 => 'value1',
  77             key2 => 'value2',
  78             array1 => [ 'elem0', 'elem1', 'elem2', ],
  79             hash1 => {
  80                 subkey1 => "subvalue1",
  81                 subkey2 => "subvalue2",
  82                 subkey3 => useclass( bless { a => 'b' }, 'Foo' ),
  83             },
  84         }),
  85         "Everything matches",
  86     );
  87
  88     $struct->{foo} = 'bar';
  89     is( $struct->{foo}, 'bar', "\$struct has foo and it's 'bar'" );
  90     ok( !exists $db->{foo}, "\$db doesn't have the 'foo' key, so \$struct is not tied" );
  91
  92     $struct->{hash1}->{foo} = 'bar';
  93     is( $struct->{hash1}->{foo}, 'bar', "\$struct->{hash1} has foo and it's 'bar'" );
  94     ok( !exists $db->{hash1}->{foo}, "\$db->{hash1} doesn't have the 'foo' key, so \$struct->{hash1} is not tied" );
  95 }
  96
  97 {
  98     my ($fh, $filename) = new_fh();
  99     my $db = DBM::Deep->new({
 100         file => $filename,
 101         fh => $fh,
 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         fh => $fh,
 136         autobless => 1,
 137     });
 138
 139     $db->{foo} = 'bar';
 140
 141     my $x;
 142     my $struct = {
 143         key1 => [
 144             2, \$x, 3,
 145         ],
 146     };
 147
 148     eval {
 149         $db->import( $struct );
 150     };
 151     like( $@, qr/Storage of references of type 'SCALAR' is not supported/, 'Error message correct' );
 152
 153     TODO: {
 154         local $TODO = "Importing cannot occur within a transaction yet.";
 155         cmp_deeply(
 156             $db,
 157             noclass({
 158                 foo => 'bar',
 159             }),
 160             "Everything matches",
 161         );
 162     }
 163 }
 164
 165 __END__
 166
 167 Need to add tests for:
 168     - Failure case (have something tied or a glob or something like that)
 169     - Where we already have $db->{hash1} to make sure that it's not overwritten