X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=t%2F15-self.t;h=adc4ec7a59e9d056eb4da86b116ff9fc11892540;hb=431bf25f01990d10db1b7da5762b087b38cf4ff8;hp=6f6d9a469b99c9df35389bb1f4965fb5be1eff56;hpb=fee1a480bc5d827590dc7394e0a77741bad86dc3;p=perl%2Fmodules%2FVariable-Magic.git

diff --git a/t/15-self.t b/t/15-self.t
index 6f6d9a4..adc4ec7 100644
--- a/t/15-self.t
+++ b/t/15-self.t
@@ -1,11 +1,19 @@
-#!perl -T
+#!perl
 
 use strict;
 use warnings;
 
-use Test::More tests => 16;
+use Test::More;
 
-use Variable::Magic qw/wizard cast dispell getdata getsig/;
+my $tests;
+BEGIN { $tests = 17 }
+
+plan tests => $tests;
+
+use Variable::Magic qw<wizard cast dispell getdata MGf_LOCAL VMG_UVAR>;
+
+use lib 't/lib';
+use Variable::Magic::TestGlobalDestruction;
 
 my $c = 0;
 
@@ -15,39 +23,168 @@ my $c = 0;
          get  => sub { ++$c },
          free => sub { --$c }
  };
- ok(!$@, "wizard creation error ($@)");
- ok(defined $wiz, 'wizard is defined');
- ok(ref $wiz eq 'SCALAR', 'wizard is a scalar ref');
+ is($@, '',             'wizard creation error doesn\'t croak');
+ ok(defined $wiz,       'wizard is defined');
+ is(ref $wiz, 'SCALAR', 'wizard is a scalar ref');
 
  my $res = eval { cast $wiz, $wiz };
- ok(!$@, "cast on self croaks ($@)");
- ok($res, 'cast on self invalid');
+ is($@, '', 'cast on self doesn\'t croak');
+ ok($res,   'cast on self is valid');
 
  my $w = $wiz;
- ok($c == 1, 'magic works correctly on self');
+ is($c, 1, 'magic works correctly on self');
 
  $res = eval { dispell $wiz, $wiz };
- ok(!$@, "dispell on self croaks ($@)");
- ok($res, 'dispell on self invalid');
+ is($@, '', 'dispell on self doesn\'t croak');
+ ok($res,   'dispell on self is valid');
 
  $w = $wiz;
- ok($c == 1, 'magic is no longer invoked on self when dispelled');
+ is($c, 1, 'magic is no longer invoked on self when dispelled');
 
  $res = eval { cast $wiz, $wiz, $wiz };
- ok(!$@, "re-cast on self croaks ($@)");
- ok($res, 're-cast on self invalid');
+ is($@, '', 're-cast on self doesn\'t croak');
+ ok($res,   're-cast on self is valid');
 
  $w = getdata $wiz, $wiz;
- ok($c == 1, 'getdata on magical self doesn\'t trigger callbacks');
- # ok(getsig($w) == getsig($wiz), 'getdata returns the correct wizard');
+ is($c, 1, 'getdata on magical self doesn\'t trigger callbacks');
 
  $res = eval { dispell $wiz, $wiz };
- ok(!$@, "re-dispell on self croaks ($@)");
- ok($res, 're-dispell on self invalid');
+ is($@, '', 're-dispell on self doesn\'t croak');
+ ok($res,   're-dispell on self is valid');
 
  $res = eval { cast $wiz, $wiz };
- ok(!$@, "re-re-cast on self croaks ($@)");
- ok($res, 're-re-cast on self invalid');
+ is($@, '', 're-re-cast on self doesn\'t croak');
+ ok($res,   're-re-cast on self is valid');
+}
+
+{
+ my %testcases;
+
+ BEGIN {
+  my %magics = do {
+   my @magics = qw<get set len clear free copy>;
+   push @magics, 'local'                       if MGf_LOCAL;
+   push @magics, qw<fetch store exists delete> if VMG_UVAR;
+   map { $_ => 1 } @magics;
+  };
+
+  %testcases = (
+   SCALAR => {
+    id    => 1,
+    ctor  => sub { my $val = 123; \$val },
+    tests => [
+     get   => [ sub { my $val = ${$_[0]} }    => 123 ],
+     set   => [ sub { ${$_[0]} = 456; $_[0] } => \456 ],
+     free  => [ ],
+    ],
+   },
+   ARRAY => {
+    id    => 2,
+    ctor  => sub { [ 0 .. 2 ]  },
+    tests => [
+     len   => [ sub { my $len = @{$_[0]} }   => 3   ],
+     clear => [ sub { @{$_[0]} = (); $_[0] } => [ ] ],
+     free  => [ ],
+    ],
+   },
+   HASH => {
+    id    => 3,
+    ctor  => sub { +{ foo => 'bar' } },
+    tests => [
+     clear  => [ sub { %{$_[0]} = (); $_[0] }          => +{ }             ],
+     free   => [ ],
+     fetch  => [ sub { my $val = $_[0]->{foo} }        => 'bar'            ],
+     store  => [ sub { $_[0]->{foo} = 'baz'; $_[0] }   => { foo => 'baz' } ],
+     exists => [ sub { my $res = exists $_[0]->{foo} } => 1                ],
+     delete => [ sub { my $val = delete $_[0]->{foo} } => 'bar'            ],
+    ],
+   },
+  );
+
+  my $count;
+
+  for my $testcases (map $_->{tests}, values %testcases) {
+   my $i = 0;
+   while ($i < $#$testcases) {
+    if ($magics{$testcases->[$i]}) {
+     $i += 2;
+     ++$count;
+    } else {
+     splice @$testcases, $i, 2;
+    }
+   }
+  }
+
+  $tests += $count * 2 * 2 * 3;
+ }
+
+ my @types = sort { $testcases{$a}->{id} <=> $testcases{$b}->{id} }
+              keys %testcases;
+
+ my $other_wiz = wizard data => sub { 'abc' };
+
+ for my $type (@types) {
+  my $ctor = $testcases{$type}->{ctor};
+
+  my @testcases = @{$testcases{$type}->{tests}};
+  while (@testcases >= 2) {
+   my ($magic, $test) = splice @testcases, 0, 2;
+
+   for my $dispell (0, 1) {
+    for my $die (0, 1) {
+     my $desc = $dispell ? 'dispell' : 'cast';
+     $desc .= " a $type from a $magic callback";
+     $desc .= ' and dieing' if $die;
+
+     my $wiz;
+     my $code = $dispell
+                ? sub { &dispell($_[0], $wiz);    die 'oops' if $die; return }
+                : sub { &cast($_[0], $other_wiz); die 'oops' if $die; return };
+     $wiz = wizard(
+      data   => sub { 'xyz' },
+      $magic => $code,
+     );
+
+     my ($var, $res, $err);
+     if ($magic eq 'free') {
+      eval {
+       my $v = $ctor->();
+       &cast($v, $wiz);
+      };
+      $err = $@;
+     } else {
+      $var = $ctor->();
+      &cast($var, $wiz);
+      $res = eval {
+       $test->[0]->($var);
+      };
+      $err = $@;
+     }
+
+     if ($die) {
+      like $err, qr/^oops at/, "$desc: correct error";
+      is $res, undef, "$desc: returned undef";
+     } else {
+      is $err, '', "$desc: no error";
+      is_deeply $res, $test->[1], "$desc: returned value";
+     }
+     if (not defined $var) {
+      pass "$desc: meaningless";
+     } elsif ($dispell) {
+      my $data = &getdata($var, $wiz);
+      is $data, undef, "$desc: correctly dispelled";
+     } else {
+      my $data = &getdata($var, $other_wiz);
+      is $data, 'abc', "$desc: correctly cast";
+     }
+    }
+   }
+  }
+ }
 }
 
-# ok($c == 0, 'magic destructor is called');
+eval q[
+ use lib 't/lib';
+ BEGIN { require Variable::Magic::TestDestroyRequired; }
+];
+is $@, '', 'wizard destruction at the end of BEGIN-time require doesn\'t panic';