t/33-code.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 14;
   7
   8 use Variable::Magic qw/wizard cast dispell/;
   9
  10 my @c = (0) x 12;
  11 my @x = (0) x 12;
  12
  13 sub check {
  14  is join(':', map { (defined) ? $_ : 'u' } @c[0 .. 11]),
  15     join(':', map { (defined) ? $_ : 'u' } @x[0 .. 11]),
  16     $_[0];
  17 }
  18
  19 my $i = -1;
  20 my $wiz = wizard get   => sub { ++$c[0] },
  21                  set   => sub { ++$c[1] },
  22                  len   => sub { ++$c[2] },
  23                  clear => sub { ++$c[3] },
  24                  free  => sub { ++$c[4] },
  25                  copy  => sub { ++$c[5] },
  26                  dup   => sub { ++$c[6] },
  27                  local => sub { ++$c[7] },
  28                  fetch => sub { ++$c[8] },
  29                  store => sub { ++$c[9] },
  30                  'exists' => sub { ++$c[10] },
  31                  'delete' => sub { ++$c[11] };
  32 check('code : create wizard');
  33
  34 my $x = 0;
  35 sub hlagh { ++$x };
  36
  37 cast &hlagh, $wiz;
  38 check('code : cast');
  39
  40 hlagh();
  41 check('code : call without arguments');
  42 is($x, 1, 'code : call without arguments succeeded');
  43
  44 hlagh(1, 2, 3);
  45 check('code : call with arguments');
  46 is($x, 2, 'code : call with arguments succeeded');
  47
  48 undef *hlagh;
  49 ++$x[4];
  50 check('code : undef symbol table');
  51 is($x, 2, 'code : undef symbol table didn\'t call');
  52
  53 my $y = 0;
  54 *hlagh = sub { ++$y };
  55
  56 cast &hlagh, $wiz;
  57 check('code : re-cast');
  58
  59 my $r = \&hlagh;
  60 check('code : take reference');
  61
  62 $r->();
  63 check('code : call reference');
  64 is($y, 1, 'code : call reference succeeded');
  65 is($x, 2, 'code : call reference didn\'t triggered the previous code');
  66
  67 dispell &hlagh, $wiz;
  68 check('code : dispell');