t/25-copy.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More;
   7
   8 use Variable::Magic qw/wizard cast MGf_COPY/;
   9
  10 if (MGf_COPY) {
  11  plan tests => 1 + 8 + 14;
  12 } else {
  13  plan skip_all => 'No copy magic for this perl' if !MGf_COPY;
  14 }
  15
  16 my $c = 0;
  17 my $wiz = wizard 'copy' => sub { ++$c };
  18 ok($c == 0, 'copy : create wizard');
  19
  20 SKIP: {
  21  eval "use Tie::Array";
  22  skip 'Tie::Array required to test copy magic on arrays', 8 if $@;
  23
  24  tie my @a, 'Tie::StdArray';
  25  @a = (1 .. 10);
  26
  27  my $res = cast @a, $wiz;
  28  ok($res,    'copy : cast on array succeeded');
  29  ok($c == 0, 'copy : cast on array didn\'t triggered the callback');
  30
  31  $a[3] = 13;
  32  ok($c == 1, 'copy : callback triggers on array store');
  33
  34  my $s = $a[3];
  35  ok($c == 2,  'copy : callback triggers on array fetch');
  36  ok($s == 13, 'copy : array fetch is correct');
  37
  38  $s = exists $a[3];
  39  ok($c == 3, 'copy : callback triggers on array exists');
  40  ok($s,      'copy : array exists is correct');
  41
  42  undef @a;
  43  ok($c == 3, 'copy : callback doesn\'t trigger on array undef');
  44 }
  45
  46 SKIP: {
  47  eval "use Tie::Has";
  48  skip 'Tie::Hash required to test copy magic on hashes', 14 if $@;
  49
  50  tie my %h, 'Tie::StdHash';
  51  %h = (a => 1, b => 2, c => 3);
  52
  53  $c = 0;
  54  my $res = cast %h, $wiz;
  55  ok($res,    'copy : cast on hash succeeded');
  56  ok($c == 0, 'copy : cast on hash didn\'t triggered the callback');
  57
  58  $h{b} = 7;
  59  ok($c == 1, 'copy : callback triggers on hash store');
  60
  61  my $s = $h{c};
  62  ok($c == 2, 'copy : callback triggers on hash fetch');
  63  ok($s == 3, 'copy : hash fetch is correct');
  64
  65  $s = exists $h{a};
  66  ok($c == 3, 'copy : callback triggers on hash exists');
  67  ok($s,      'copy : hash exists is correct');
  68
  69  $s = delete $h{b};
  70  ok($c == 4, 'copy : callback triggers on hash delete');
  71  ok($s == 7, 'copy : hash delete is correct');
  72
  73  my ($k, $v) = each %h;
  74  ok($c == 5, 'copy : callback triggers on hash each');
  75
  76  my @k = keys %h;
  77  ok($c == 5, 'copy : callback doesn\'t trigger on hash keys');
  78
  79  my @v = values %h;
  80  ok(@v == 2, 'copy : two values in the hash');
  81  ok($c == 7, 'copy : callback triggers on hash values');
  82
  83  undef %h;
  84  ok($c == 7, 'copy : callback doesn\'t trigger on hash undef');
  85 }