t/16-huf.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More;
   7
   8 use Variable::Magic qw/wizard cast dispell VMG_UVAR/;
   9
  10 if (!VMG_UVAR) {
  11  plan skip_all => 'No nice uvar magic for this perl';
  12 }
  13
  14 eval "use Hash::Util::FieldHash";
  15 if ($@) {
  16  plan skip_all => 'Hash::Util::FieldHash required for testing uvar interaction';
  17 } else {
  18  plan tests => 12;
  19  my $v = $Hash::Util::FieldHash::VERSION;
  20  diag "Using Hash::Util::FieldHash $v" if defined $v;
  21 }
  22
  23 Hash::Util::FieldHash::fieldhash(\my %h);
  24
  25 my $obj = { };
  26 bless $obj, 'Variable::Magic::Test::Mock';
  27 $h{$obj} = 5;
  28
  29 my ($w, $c) = (undef, 0);
  30
  31 eval { $w = wizard fetch => sub { ++$c }, store => sub { --$c } };
  32 ok(!$@,              "wizard with uvar doesn't croak ($@)");
  33 ok(defined $w,       'wizard with uvar is defined');
  34 is(ref $w, 'SCALAR', 'wizard with uvar is a scalar ref');
  35
  36 my $res = eval { cast %h, $w };
  37 ok(!$@,  "cast uvar magic on fieldhash doesn't croak ($@)");
  38 ok($res, 'cast uvar magic on fieldhash is valid');
  39
  40 my $s = $h{$obj};
  41 is($s, 5, 'fetch magic on fieldhash doesn\'t clobber');
  42 is($c, 1, 'fetch magic on fieldhash');
  43
  44 $h{$obj} = 7;
  45 is($c, 0,       'store magic on fieldhash');
  46 is($h{$obj}, 7, 'store magic on fieldhash doesn\'t clobber'); # $c == 1
  47
  48 $res = eval { dispell %h, $w };
  49 ok(!$@,  "dispell uvar magic on fieldhash doesn't croak ($@)");
  50 ok($res, 'dispell uvar magic on fieldhash is valid');
  51
  52 $h{$obj} = 11;
  53 $s = $h{$obj};
  54 is($s, 11, 'store/fetch on fieldhash after dispell still ok');