t/17_import.t

   1 use strict;
   2 use warnings FATAL => 'all';
   3
   4 use Test::More;
   5 use Test::Deep;
   6 use Test::Exception;
   7 use t::common qw( new_dbm );
   8
   9 use_ok( 'DBM::Deep' );
  10
  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->();
  16
  17         # Load a scalar
  18         throws_ok {
  19             $db->import( 'foo' );
  20         } qr/Cannot import a scalar/, "Importing a scalar to type '$type' fails";
  21
  22         # Load a ref of the wrong type
  23         # Load something with bad stuff in it
  24         my $x = 3;
  25         if ( $type eq 'A' ) {
  26             throws_ok {
  27                 $db->import( { foo => 'bar' } );
  28             } qr/Cannot import a hash into an array/, "Wrong type fails";
  29
  30             throws_ok {
  31                 $db->import( [ \$x ] );
  32             } qr/Storage of references of type 'SCALAR' is not supported/, "Bad stuff fails";
  33         }
  34         else {
  35             throws_ok {
  36                 $db->import( [ 1 .. 3 ] );
  37             } qr/Cannot import an array into a hash/, "Wrong type fails";
  38
  39             throws_ok {
  40                 $db->import( { foo => \$x } );
  41             } qr/Storage of references of type 'SCALAR' is not supported/, "Bad stuff fails";
  42         }
  43     }
  44 }
  45
  46 my $dbm_factory = new_dbm( autobless => 1 );
  47 while ( my $dbm_maker = $dbm_factory->() ) {
  48     my $db = $dbm_maker->();
  49
  50     ##
  51     # Create structure in memory
  52     ##
  53     my $struct = {
  54         key1 => "value1",
  55         key2 => "value2",
  56         array1 => [ "elem0", "elem1", "elem2" ],
  57         hash1 => {
  58             subkey1 => "subvalue1",
  59             subkey2 => "subvalue2",
  60             subkey3 => bless( { a => 'b' }, 'Foo' ),
  61         }
  62     };
  63
  64     $db->import( $struct );
  65
  66     cmp_deeply(
  67         $db,
  68         noclass({
  69             key1 => 'value1',
  70             key2 => 'value2',
  71             array1 => [ 'elem0', 'elem1', 'elem2', ],
  72             hash1 => {
  73                 subkey1 => "subvalue1",
  74                 subkey2 => "subvalue2",
  75                 subkey3 => useclass( bless { a => 'b' }, 'Foo' ),
  76             },
  77         }),
  78         "Everything matches",
  79     );
  80
  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" );
  84
  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" );
  88 }
  89
  90 $dbm_factory = new_dbm( type => DBM::Deep->TYPE_ARRAY );
  91 while ( my $dbm_maker = $dbm_factory->() ) {
  92     my $db = $dbm_maker->();
  93
  94     my $struct = [
  95         1 .. 3,
  96         [ 2, 4, 6 ],
  97         bless( [], 'Bar' ),
  98         { foo => [ 2 .. 4 ] },
  99     ];
 100
 101     $db->import( $struct );
 102
 103     cmp_deeply(
 104         $db,
 105         noclass([
 106             1 .. 3,
 107             [ 2, 4, 6 ],
 108             useclass( bless( [], 'Bar' ) ),
 109             { foo => [ 2 .. 4 ] },
 110         ]),
 111         "Everything matches",
 112     );
 113
 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" );
 117 }
 118
 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->();
 123
 124     $db->{foo} = 'bar';
 125
 126     my $x;
 127     my $struct = {
 128         key1 => [
 129             2, \$x, 3,
 130         ],
 131     };
 132
 133     eval {
 134         $db->import( $struct );
 135     };
 136     like( $@, qr/Storage of references of type 'SCALAR' is not supported/, 'Error message correct' );
 137
 138     TODO: {
 139         local $TODO = "Importing cannot occur within a transaction yet.";
 140         cmp_deeply(
 141             $db,
 142             noclass({
 143                 foo => 'bar',
 144             }),
 145             "Everything matches",
 146         );
 147     }
 148 }
 149
 150 done_testing;
 151
 152 __END__
 153
 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