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