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