t/28-uvar.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 tests => 20;
  12 } else {
  13  plan skip_all => 'No nice uvar magic for this perl';
  14 }
  15
  16 my @c = (0) x 4;
  17 my @x = (0) x 4;
  18
  19 sub check {
  20  is join(':', map { (defined) ? $_ : 'u' } @c[0 .. 3]),
  21     join(':', map { (defined) ? $_ : 'u' } @x[0 .. 3]),
  22     $_[0];
  23 }
  24
  25 my $wiz = wizard 'fetch'  => sub { ++$c[0] },
  26                  'store'  => sub { ++$c[1] },
  27                  'exists' => sub { ++$c[2] },
  28                  'delete' => sub { ++$c[3] };
  29 check('uvar : create wizard');
  30
  31 my %h = (a => 1, b => 2, c => 3);
  32 my $res = cast %h, $wiz;
  33 ok($res, 'uvar : cast succeeded');
  34 check(   'uvar : cast didn\'t triggered the callback');
  35
  36 my $x = $h{a};
  37 ++$x[0];
  38 check( 'uvar : fetch directly');
  39 ok($x, 'uvar : fetch directly correctly');
  40
  41 $x = "$h{b}";
  42 ++$x[0];
  43 check(    'uvar : fetch by interpolation');
  44 is($x, 2, 'uvar : fetch by interpolation correctly');
  45
  46 $h{c} = 4;
  47 ++$x[1];
  48 check('uvar : store directly');
  49
  50 $x = $h{c} = 5;
  51 ++$x[1];
  52 check(    'uvar : fetch and store');
  53 is($x, 5, 'uvar : fetch and store correctly');
  54
  55 $x = exists $h{c};
  56 ++$x[2];
  57 check( 'uvar : exists');
  58 ok($x, 'uvar : exists correctly');
  59
  60 $x = delete $h{c};
  61 ++$x[3];
  62 check(    'uvar : delete existing key');
  63 is($x, 5, 'uvar : delete existing key correctly');
  64
  65 $x = delete $h{z};
  66 ++$x[3];
  67 check(          'uvar : delete non-existing key');
  68 ok(!defined $x, 'uvar : delete non-existing key correctly');
  69
  70 my $wiz2 = wizard 'fetch'  => sub { 0 };
  71 my %h2 = (a => 37, b => 2, c => 3);
  72 cast %h2, $wiz2;
  73
  74 eval {
  75  local $SIG{__WARN__} = sub { die };
  76  $x = $h2{a};
  77 };
  78 is($@, '', 'uvar : fetch with incomplete magic');
  79 is($x, 37, 'uvar : fetch with incomplete magic correctly');
  80
  81 eval {
  82  local $SIG{__WARN__} = sub { die };
  83  $h2{a} = 73;
  84 };
  85 is($@, '',     'uvar : store with incomplete magic');
  86 is($h2{a}, 73, 'uvar : store with incomplete magic correctly');