8 use Variable::Magic qw/wizard cast MGf_COPY/;
11 plan tests => 1 + 8 + 14;
13 plan skip_all => 'No copy magic for this perl' if !MGf_COPY;
17 my $wiz = wizard 'copy' => sub { ++$c };
18 is($c, 0, 'copy : create wizard');
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;
25 tie my @a, 'Tie::StdArray';
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');
33 is($c, 1, 'copy : callback triggers on array store');
36 is($c, 2, 'copy : callback triggers on array fetch');
37 is($s, 13, 'copy : array fetch is correct');
40 is($c, 3, 'copy : callback triggers on array exists');
41 ok($s, 'copy : array exists is correct');
44 is($c, 3, 'copy : callback doesn\'t trigger on array undef');
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;
52 tie my %h, 'Tie::StdHash';
53 %h = (a => 1, b => 2, c => 3);
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');
61 is($c, 1, 'copy : callback triggers on hash store');
64 is($c, 2, 'copy : callback triggers on hash fetch');
65 is($s, 3, 'copy : hash fetch is correct');
68 is($c, 3, 'copy : callback triggers on hash exists');
69 ok($s, 'copy : hash exists is correct');
72 is($c, 4, 'copy : callback triggers on hash delete');
73 is($s, 7, 'copy : hash delete is correct');
75 my ($k, $v) = each %h;
76 is($c, 5, 'copy : callback triggers on hash each');
79 is($c, 5, 'copy : callback doesn\'t trigger on hash keys');
82 is(scalar @v, 2, 'copy : two values in the hash');
83 is($c, 7, 'copy : callback triggers on hash values');
86 is($c, 7, 'copy : callback doesn\'t trigger on hash undef');