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     SKIP: {
  18         skip "This engine doesn't support singletons", 8
  19             unless $db->supports( 'singletons' );
  20
  21         $db->{a} = 1;
  22         $db->{foo} = { a => 'b' };
  23         my $x = $db->{foo};
  24         my $y = $db->{foo};
  25
  26         is( $x, $y, "The references are the same" );
  27
  28         delete $db->{foo};
  29         is( $x, undef, "After deleting the DB location, external references are also undef (\$x)" );
  30         is( $y, undef, "After deleting the DB location, external references are also undef (\$y)" );
  31         is( eval { $x + 0 }, undef, "DBM::Deep::Null can be added to." );
  32         is( eval { $y + 0 }, undef, "DBM::Deep::Null can be added to." );
  33         is( $db->{foo}, undef, "The {foo} location is also undef." );
  34
  35         # These shenanigans work to get another hashref
  36         # into the same data location as $db->{foo} was.
  37         $db->{foo} = {};
  38         delete $db->{foo};
  39         $db->{foo} = {};
  40         $db->{bar} = {};
  41
  42         is( $x, undef, "After re-assigning to {foo}, external references to old values are still undef (\$x)" );
  43         is( $y, undef, "After re-assigning to {foo}, external references to old values are still undef (\$y)" );
  44     }
  45 }
  46
  47 SKIP: {
  48     skip "What do we do with external references and txns?", 2;
  49
  50     my $dbm_factory = new_dbm(
  51         locking   => 1,
  52         autoflush => 1,
  53         num_txns  => 2,
  54     );
  55     while ( my $dbm_maker = $dbm_factory->() ) {
  56         my $db = $dbm_maker->();
  57
  58         $db->{foo} = { a => 'b' };
  59         my $x = $db->{foo};
  60
  61         $db->begin_work;
  62
  63             $db->{foo} = { c => 'd' };
  64             my $y = $db->{foo};
  65
  66             # XXX What should happen here with $x and $y?
  67             is( $x, $y );
  68             is( $x->{c}, 'd' );
  69
  70         $db->rollback;
  71     }
  72 }
  73
  74 done_testing;