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 is($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  diag "Using Tie::Array $Tie::Array::VERSION" if defined $Tie::Array::VERSION;
  24
  25  tie my @a, 'Tie::StdArray';
  26  @a = (1 .. 10);
  27
  28  my $res = cast @a, $wiz;
  29  ok($res,  'copy : cast on array succeeded');
  30  is($c, 0, 'copy : cast on array didn\'t triggered the callback');
  31
  32  $a[3] = 13;
  33  is($c, 1, 'copy : callback triggers on array store');
  34
  35  my $s = $a[3];
  36  is($c, 2,  'copy : callback triggers on array fetch');
  37  is($s, 13, 'copy : array fetch is correct');
  38
  39  $s = exists $a[3];
  40  is($c, 3, 'copy : callback triggers on array exists');
  41  ok($s,    'copy : array exists is correct');
  42
  43  undef @a;
  44  is($c, 3, 'copy : callback doesn\'t trigger on array undef');
  45 }
  46
  47 SKIP: {
  48  eval "use Tie::Hash";
  49  skip 'Tie::Hash required to test copy magic on hashes', 14 if $@;
  50  diag "Using Tie::Hash $Tie::Hash::VERSION" if defined $Tie::Hash::VERSION;
  51
  52  tie my %h, 'Tie::StdHash';
  53  %h = (a => 1, b => 2, c => 3);
  54
  55  $c = 0;
  56  my $res = cast %h, $wiz;
  57  ok($res,  'copy : cast on hash succeeded');
  58  is($c, 0, 'copy : cast on hash didn\'t triggered the callback');
  59
  60  $h{b} = 7;
  61  is($c, 1, 'copy : callback triggers on hash store');
  62
  63  my $s = $h{c};
  64  is($c, 2, 'copy : callback triggers on hash fetch');
  65  is($s, 3, 'copy : hash fetch is correct');
  66
  67  $s = exists $h{a};
  68  is($c, 3, 'copy : callback triggers on hash exists');
  69  ok($s,    'copy : hash exists is correct');
  70
  71  $s = delete $h{b};
  72  is($c, 4, 'copy : callback triggers on hash delete');
  73  is($s, 7, 'copy : hash delete is correct');
  74
  75  my ($k, $v) = each %h;
  76  is($c, 5, 'copy : callback triggers on hash each');
  77
  78  my @k = keys %h;
  79  is($c, 5, 'copy : callback doesn\'t trigger on hash keys');
  80
  81  my @v = values %h;
  82  is(scalar @v, 2, 'copy : two values in the hash');
  83  is($c, 7,        'copy : callback triggers on hash values');
  84
  85  undef %h;
  86  is($c, 7, 'copy : callback doesn\'t trigger on hash undef');
  87 }