X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=t%2F25-copy.t;h=cb00b6322ce90db2be5754297a01d16f587a8753;hb=47fcdae90d7af36c40b950c1154fa2dd306b5edb;hp=58cf8e91db6df1ce407174a6a2ebe20528ba8937;hpb=183e73e0590b46550dfa6fdd4b6cf3280c1a5877;p=perl%2Fmodules%2FVariable-Magic.git

diff --git a/t/25-copy.t b/t/25-copy.t
index 58cf8e9..cb00b63 100644
--- a/t/25-copy.t
+++ b/t/25-copy.t
@@ -7,57 +7,81 @@ use Test::More;
 
 use Variable::Magic qw/wizard cast MGf_COPY/;
 
-if (!MGf_COPY) {
- plan skip_all => "this perl doesn't handle copy magic";
+if (MGf_COPY) {
+ plan tests => 1 + 8 + 14;
 } else {
- plan tests => 16;
+ plan skip_all => 'No copy magic for this perl' if !MGf_COPY;
 }
 
 my $c = 0;
-my $wiz = wizard copy => sub { ++$c };
-ok($c == 0, 'copy : create wizard');
+my $wiz = wizard 'copy' => sub { ++$c };
+is($c, 0, 'copy : create wizard');
 
-use Tie::Array;
+SKIP: {
+ eval "use Tie::Array";
+ skip 'Tie::Array required to test copy magic on arrays', 8 if $@;
+ diag "Using Tie::Array $Tie::Array::VERSION" if defined $Tie::Array::VERSION;
 
-tie my @a, 'Tie::StdArray';
-cast @a, $wiz;
-ok($c == 0, 'copy (array) : cast');
+ tie my @a, 'Tie::StdArray';
+ @a = (1 .. 10);
 
-my $n = time;
-$a[0] = $n;
-ok($c == 1, 'copy (array) : store element');
+ my $res = cast @a, $wiz;
+ ok($res,  'copy : cast on array succeeded');
+ is($c, 0, 'copy : cast on array didn\'t triggered the callback');
 
-my $e = exists $a[0];
-ok($c == 2, 'copy (array) : exists element');
-ok($e,      'copy (array) : exists element, really'); 
+ $a[3] = 13;
+ is($c, 1, 'copy : callback triggers on array store');
 
-my $b = $a[0];
-ok($c == 3, 'copy (array) : fetch element');
-ok($b == $n, 'copy (array) : fetch element correctly');
+ my $s = $a[3];
+ is($c, 2,  'copy : callback triggers on array fetch');
+ is($s, 13, 'copy : array fetch is correct');
 
-use Tie::Hash;
+ $s = exists $a[3];
+ is($c, 3, 'copy : callback triggers on array exists');
+ ok($s,    'copy : array exists is correct');
 
-$c = 0;
+ undef @a;
+ is($c, 3, 'copy : callback doesn\'t trigger on array undef');
+}
+
+SKIP: {
+ eval "use Tie::Hash";
+ skip 'Tie::Hash required to test copy magic on hashes', 14 if $@;
+ diag "Using Tie::Hash $Tie::Hash::VERSION" if defined $Tie::Hash::VERSION;
+
+ tie my %h, 'Tie::StdHash';
+ %h = (a => 1, b => 2, c => 3);
+
+ $c = 0;
+ my $res = cast %h, $wiz;
+ ok($res,  'copy : cast on hash succeeded');
+ is($c, 0, 'copy : cast on hash didn\'t triggered the callback');
 
-tie my %h, 'Tie::StdHash';
-cast %h, $wiz;
-ok($c == 0, 'copy (hash) : cast');
+ $h{b} = 7;
+ is($c, 1, 'copy : callback triggers on hash store');
 
-my ($k, $v) = (time, int rand time);
-$h{$k} = $v;
-ok($c == 1, 'copy (hash) : store element');
+ my $s = $h{c};
+ is($c, 2, 'copy : callback triggers on hash fetch');
+ is($s, 3, 'copy : hash fetch is correct');
 
-$e = exists $h{$k};
-ok($c == 2, 'copy (hash) : exists element');
-ok($e,      'copy (hash) : exists element, really');
+ $s = exists $h{a};
+ is($c, 3, 'copy : callback triggers on hash exists');
+ ok($s,    'copy : hash exists is correct');
 
-my $w = $h{$k};
-ok($c == 3, 'copy (hash) : fetch element');
-ok($w == $v, 'copy (hash) : fetch element correctly');
+ $s = delete $h{b};
+ is($c, 4, 'copy : callback triggers on hash delete');
+ is($s, 7, 'copy : hash delete is correct');
 
-my ($K, $V) = each %h;
-ok($c == 4, 'copy (hash) : iterate');
-ok($k == $K && $v == $V, 'copy (hash) : iterate correctly');
+ my ($k, $v) = each %h;
+ is($c, 5, 'copy : callback triggers on hash each');
 
-delete $h{$k};
-ok($c == 5, 'copy (hash) : delete');
+ my @k = keys %h;
+ is($c, 5, 'copy : callback doesn\'t trigger on hash keys');
+
+ my @v = values %h;
+ is(scalar @v, 2, 'copy : two values in the hash');
+ is($c, 7,        'copy : callback triggers on hash values');
+
+ undef %h;
+ is($c, 7, 'copy : callback doesn\'t trigger on hash undef');
+}