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 qw/fieldhash/";
  15 if ($@) {
  16  plan skip_all => 'Hash::Util::FieldHash required for testing uvar interaction';
  17 } else {
  18  plan tests => 12;
  19 }
  20
  21 fieldhash(my %h);
  22
  23 bless \(my $obj = {}), 'Variable::Magic::Test::Mock';
  24 $h{$obj} = 5;
  25
  26 my ($w, $c) = (undef, 0);
  27
  28 eval { $w = wizard fetch => sub { ++$c }, store => sub { --$c } };
  29 ok(!$@, "wizard with uvar creation error ($@)");
  30 ok(defined $w, 'wizard with uvar is defined');
  31 ok(ref($w) eq 'SCALAR', 'wizard with uvar is a scalar ref');
  32
  33 my $res = eval { cast %h, $w };
  34 ok(!$@, "cast uvar magic on fieldhash croaks ($@)");
  35 ok($res, 'cast uvar magic on fieldhash invalid');
  36
  37 my $s = $h{$obj};
  38 ok($s == 5, 'fetch magic on fieldhash doesn\'t clobber');
  39 ok($c == 1, 'fetch magic on fieldhash');
  40
  41 $h{$obj} = 7;
  42 ok($c == 0, 'store magic on fieldhash');
  43 ok($h{$obj} == 7, 'store magic on fieldhash doesn\'t clobber'); # $c == 1
  44
  45 $res = eval { dispell %h, $w };
  46 ok(!$@, "dispell uvar magic on fieldhash croaks ($@)");
  47 ok($res, 'dispell uvar magic on fieldhash invalid');
  48
  49 $h{$obj} = 11;
  50 $s = $h{$obj};
  51 ok($s == 11, 'store/fetch on fieldhash after dispell still ok');