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 => 16;
  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
  33 ok($res,    'uvar : cast succeeded');
  34 ok(check(), 'uvar : cast didn\'t triggered the callback');
  35
  36 my $x = $h{a};
  37 ++$x[0];
  38 ok(check(), 'uvar : fetch directly');
  39 ok($x,      'uvar : fetch directly correctly');
  40
  41 $x = "$h{b}";
  42 ++$x[0];
  43 ok(check(), 'uvar : fetch by interpolation');
  44 ok($x == 2, 'uvar : fetch by interpolation correctly');
  45
  46 $h{c} = 4;
  47 ++$x[1];
  48 ok(check(), 'uvar : store directly');
  49
  50 $x = $h{c} = 5;
  51 ++$x[1];
  52 ok(check(), 'uvar : fetch and store');
  53 ok($x == 5, 'uvar : fetch and store correctly');
  54
  55 $x = exists $h{c};
  56 ++$x[2];
  57 ok(check(), 'uvar : exists');
  58 ok($x,      'uvar : exists correctly');
  59
  60 $x = delete $h{c};
  61 ++$x[3];
  62 ok(check(), 'uvar : delete existing key');
  63 ok($x == 5, 'uvar : delete existing key correctly');
  64
  65 $x = delete $h{z};
  66 ++$x[3];
  67 ok(check(),     'uvar : delete non-existing key');
  68 ok(!defined $x, 'uvar : delete non-existing key correctly');
  69