t/39_singletons.t

   1 use strict;
   2 use warnings FATAL => 'all';
   3
   4 use Test::More;
   5 use Test::Deep;
   6 use t::common qw( new_dbm );
   7
   8 use_ok( 'DBM::Deep' );
   9
  10 my $dbm_factory = new_dbm(
  11     locking => 1,
  12     autoflush => 1,
  13 );
  14 while ( my $dbm_maker = $dbm_factory->() ) {
  15     my $db = $dbm_maker->();
  16
  17     $db->{a} = 1;
  18     $db->{foo} = { a => 'b' };
  19     my $x = $db->{foo};
  20     my $y = $db->{foo};
  21
  22     is( $x, $y, "The references are the same" );
  23
  24     delete $db->{foo};
  25     is( $x, undef, "After deleting the DB location, external references are also undef (\$x)" );
  26     is( $y, undef, "After deleting the DB location, external references are also undef (\$y)" );
  27     is( $x + 0, undef, "DBM::Deep::Null can be added to." );
  28     is( $y + 0, undef, "DBM::Deep::Null can be added to." );
  29     is( $db->{foo}, undef, "The {foo} location is also undef." );
  30
  31     # These shenanigans work to get another hashref
  32     # into the same data location as $db->{foo} was.
  33     $db->{foo} = {};
  34     delete $db->{foo};
  35     $db->{foo} = {};
  36     $db->{bar} = {};
  37
  38     is( $x, undef, "After re-assigning to {foo}, external references to old values are still undef (\$x)" );
  39     is( $y, undef, "After re-assigning to {foo}, external references to old values are still undef (\$y)" );
  40 }
  41
  42 SKIP: {
  43     skip "What do we do with external references and txns?", 2;
  44
  45     my $dbm_factory = new_dbm(
  46         locking   => 1,
  47         autoflush => 1,
  48         num_txns  => 2,
  49     );
  50     while ( my $dbm_maker = $dbm_factory->() ) {
  51         my $db = $dbm_maker->();
  52
  53         $db->{foo} = { a => 'b' };
  54         my $x = $db->{foo};
  55
  56         $db->begin_work;
  57
  58             $db->{foo} = { c => 'd' };
  59             my $y = $db->{foo};
  60
  61             # XXX What should happen here with $x and $y?
  62             is( $x, $y );
  63             is( $x->{c}, 'd' );
  64
  65         $db->rollback;
  66     }
  67 }
  68
  69 done_testing;