-#!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;
$w = getdata $wiz, $wiz;
is($c, 1, 'getdata on magical self doesn\'t trigger callbacks');
- # is(getsig($w), getsig($wiz), 'getdata returns the correct wizard');
$res = eval { dispell $wiz, $wiz };
is($@, '', 're-dispell on self doesn\'t croak');
ok($res, 're-re-cast on self is valid');
}
-if ((defined $ENV{PERL_DESTRUCT_LEVEL} and $ENV{PERL_DESTRUCT_LEVEL} >= 3)
- or eval "use Perl::Destruct::Level level => 3; 1") {
- diag 'Test global destruction';
+{
+ 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";
+ }
+ }
+ }
+ }
+ }
}
-# is($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';