t/45_references.t

   1 ##
   2 # DBM::Deep Test
   3 ##
   4 use strict;
   5 use Test::More tests => 15;
   6 use Test::Exception;
   7 use t::common qw( new_fh );
   8
   9 use_ok( 'DBM::Deep' );
  10
  11 my ($fh, $filename) = new_fh();
  12 my $db = DBM::Deep->new(
  13     file => $filename,
  14     fh => $fh,
  15     locking => 1,
  16     autoflush => 1,
  17     num_txns  => 16,
  18 );
  19
  20 seek $db->_get_self->_engine->storage->{fh}, 0, 0;
  21
  22 my $db2 = DBM::Deep->new(
  23     file => $filename,
  24     fh => $fh,
  25     locking => 1,
  26     autoflush => 1,
  27     num_txns  => 16,
  28 );
  29
  30 $db->{foo} = 5;
  31 $db->{bar} = $db->{foo};
  32
  33 is( $db->{foo}, 5, "Foo is still 5" );
  34 is( $db->{bar}, 5, "Bar is now 5" );
  35
  36 $db->{foo} = 6;
  37
  38 is( $db->{foo}, 6, "Foo is now 6" );
  39 is( $db->{bar}, 5, "Bar is still 5" );
  40
  41 $db->{foo} = [ 1 .. 3 ];
  42 $db->{bar} = $db->{foo};
  43
  44 is( $db->{foo}[1], 2, "Foo[1] is still 2" );
  45 is( $db->{bar}[1], 2, "Bar[1] is now 2" );
  46
  47 $db->{foo}[3] = 42;
  48
  49 is( $db->{foo}[3], 42, "Foo[3] is now 42" );
  50 is( $db->{bar}[3], 42, "Bar[3] is also 42" );
  51
  52 delete $db->{foo};
  53 is( $db->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" );
  54
  55 $db->{foo} = $db->{bar};
  56 $db2->begin_work;
  57
  58     delete $db2->{bar};
  59     delete $db2->{foo};
  60
  61     is( $db2->{bar}, undef, "It's deleted in the transaction" );
  62     is( $db->{bar}[3], 42, "... but not in the main" );
  63
  64 $db2->rollback;
  65
  66 # Why hasn't this failed!? Is it because stuff isn't getting deleted as expected?
  67 # I need a test that walks the sectors
  68 is( $db->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" );
  69 is( $db2->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" );
  70
  71 delete $db->{foo};
  72
  73 is( $db->{bar}[3], 42, "After delete Foo, Bar[3] is still 42" );
  74
  75 __END__
  76 warn "-2\n";
  77 $db2->begin_work;
  78
  79 warn "-1\n";
  80   delete $db2->{bar};
  81
  82 warn "0\n";
  83 $db2->commit;
  84
  85 warn "1\n";
  86 ok( !exists $db->{bar}, "After commit, bar is gone" );
  87 warn "2\n";