t/32-hash.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 18;
   7
   8 use Variable::Magic qw/wizard cast dispell MGf_COPY VMG_UVAR/;
   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 $wiz = wizard get   => sub { ++$c[0] },
  20                  set   => sub { ++$c[1] },
  21                  len   => sub { ++$c[2]; $_[2] },
  22                  clear => sub { ++$c[3] },
  23                  free  => sub { ++$c[4] },
  24                  copy  => sub { ++$c[5] },
  25                  dup   => sub { ++$c[6] },
  26                  local => sub { ++$c[7] },
  27                  fetch => sub { ++$c[8] },
  28                  store => sub { ++$c[9] },
  29                  'exists' => sub { ++$c[10] },
  30                  'delete' => sub { ++$c[11] };
  31 check('hash : create wizard');
  32
  33 my %n = map { $_ => int rand 1000 } qw/foo bar baz qux/;
  34 my %a = %n;
  35
  36 cast %a, $wiz;
  37 check('hash : cast');
  38
  39 my $b = $a{foo};
  40 ++$x[5] if MGf_COPY;
  41 ++$x[8] if VMG_UVAR;
  42 check('hash : assign element to');
  43
  44 my %b = %a;
  45 check('hash : assign to');
  46
  47 $b = "X%{a}Y";
  48 check('hash : interpolate');
  49
  50 $b = \%a;
  51 check('hash : reference');
  52
  53 my @b = @a{qw/bar qux/};
  54 $x[5] += 2 if MGf_COPY;
  55 $x[8] += 2 if VMG_UVAR;
  56 check('hash : slice');
  57
  58 %a = (a => 1, d => 3);
  59 ++$x[3];
  60 $x[5] += 2 if VMG_UVAR;
  61 $x[9] += 2 if VMG_UVAR;
  62 check('hash : assign from list');
  63
  64 %a = map { $_ => 1 } qw/a b d/;
  65 ++$x[3];
  66 $x[5] += 3 if VMG_UVAR;
  67 $x[9] += 3 if VMG_UVAR;
  68 check('hash : assign from map');
  69
  70 $a{d} = 2;
  71 ++$x[5] if MGf_COPY;
  72 ++$x[9] if VMG_UVAR;
  73 check('hash : assign old element');
  74
  75 $a{c} = 3;
  76 ++$x[5] if MGf_COPY;
  77 ++$x[9] if VMG_UVAR;
  78 check('hash : assign new element');
  79
  80 $b = %a;
  81 check('hash : buckets');
  82
  83 @b = keys %a;
  84 check('hash : keys');
  85
  86 @b = values %a;
  87 check('hash : values');
  88
  89 while (my ($k, $v) = each %a) { }
  90 check('hash : each');
  91
  92 {
  93  my %b = %n;
  94  cast %b, $wiz;
  95 }
  96 ++$x[4];
  97 check('hash : scope end');
  98
  99 undef %a;
 100 ++$x[3];
 101 check('hash : undef');
 102
 103 dispell %a, $wiz;
 104 check('hash : dispel');