t/15-self.t

   1 #!perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More;
   7
   8 my $tests;
   9 BEGIN { $tests = 17 }
  10
  11 plan tests => $tests;
  12
  13 use Variable::Magic qw<wizard cast dispell getdata MGf_LOCAL VMG_UVAR>;
  14
  15 use lib 't/lib';
  16 use Variable::Magic::TestGlobalDestruction;
  17
  18 my $c = 0;
  19
  20 {
  21  my $wiz = eval {
  22   wizard data => sub { $_[0] },
  23          get  => sub { ++$c },
  24          free => sub { --$c }
  25  };
  26  is($@, '',             'wizard creation error doesn\'t croak');
  27  ok(defined $wiz,       'wizard is defined');
  28  is(ref $wiz, 'SCALAR', 'wizard is a scalar ref');
  29
  30  my $res = eval { cast $wiz, $wiz };
  31  is($@, '', 'cast on self doesn\'t croak');
  32  ok($res,   'cast on self is valid');
  33
  34  my $w = $wiz;
  35  is($c, 1, 'magic works correctly on self');
  36
  37  $res = eval { dispell $wiz, $wiz };
  38  is($@, '', 'dispell on self doesn\'t croak');
  39  ok($res,   'dispell on self is valid');
  40
  41  $w = $wiz;
  42  is($c, 1, 'magic is no longer invoked on self when dispelled');
  43
  44  $res = eval { cast $wiz, $wiz, $wiz };
  45  is($@, '', 're-cast on self doesn\'t croak');
  46  ok($res,   're-cast on self is valid');
  47
  48  $w = getdata $wiz, $wiz;
  49  is($c, 1, 'getdata on magical self doesn\'t trigger callbacks');
  50
  51  $res = eval { dispell $wiz, $wiz };
  52  is($@, '', 're-dispell on self doesn\'t croak');
  53  ok($res,   're-dispell on self is valid');
  54
  55  $res = eval { cast $wiz, $wiz };
  56  is($@, '', 're-re-cast on self doesn\'t croak');
  57  ok($res,   're-re-cast on self is valid');
  58 }
  59
  60 {
  61  my %testcases;
  62
  63  BEGIN {
  64   my %magics = do {
  65    my @magics = qw<get set len clear free copy>;
  66    push @magics, 'local'                       if MGf_LOCAL;
  67    push @magics, qw<fetch store exists delete> if VMG_UVAR;
  68    map { $_ => 1 } @magics;
  69   };
  70
  71   %testcases = (
  72    SCALAR => {
  73     id    => 1,
  74     ctor  => sub { my $val = 123; \$val },
  75     tests => [
  76      get   => [ sub { my $val = ${$_[0]} }    => 123 ],
  77      set   => [ sub { ${$_[0]} = 456; $_[0] } => \456 ],
  78      free  => [ ],
  79     ],
  80    },
  81    ARRAY => {
  82     id    => 2,
  83     ctor  => sub { [ 0 .. 2 ]  },
  84     tests => [
  85      len   => [ sub { my $len = @{$_[0]} }   => 3   ],
  86      clear => [ sub { @{$_[0]} = (); $_[0] } => [ ] ],
  87      free  => [ ],
  88     ],
  89    },
  90    HASH => {
  91     id    => 3,
  92     ctor  => sub { +{ foo => 'bar' } },
  93     tests => [
  94      clear  => [ sub { %{$_[0]} = (); $_[0] }          => +{ }             ],
  95      free   => [ ],
  96      fetch  => [ sub { my $val = $_[0]->{foo} }        => 'bar'            ],
  97      store  => [ sub { $_[0]->{foo} = 'baz'; $_[0] }   => { foo => 'baz' } ],
  98      exists => [ sub { my $res = exists $_[0]->{foo} } => 1                ],
  99      delete => [ sub { my $val = delete $_[0]->{foo} } => 'bar'            ],
 100     ],
 101    },
 102   );
 103
 104   my $count;
 105
 106   for my $testcases (map $_->{tests}, values %testcases) {
 107    my $i = 0;
 108    while ($i < $#$testcases) {
 109     if ($magics{$testcases->[$i]}) {
 110      $i += 2;
 111      ++$count;
 112     } else {
 113      splice @$testcases, $i, 2;
 114     }
 115    }
 116   }
 117
 118   $tests += $count * 2 * 2 * 3;
 119  }
 120
 121  my @types = sort { $testcases{$a}->{id} <=> $testcases{$b}->{id} }
 122               keys %testcases;
 123
 124  my $other_wiz = wizard data => sub { 'abc' };
 125
 126  for my $type (@types) {
 127   my $ctor = $testcases{$type}->{ctor};
 128
 129   my @testcases = @{$testcases{$type}->{tests}};
 130   while (@testcases >= 2) {
 131    my ($magic, $test) = splice @testcases, 0, 2;
 132
 133    for my $dispell (0, 1) {
 134     for my $die (0, 1) {
 135      my $desc = $dispell ? 'dispell' : 'cast';
 136      $desc .= " a $type from a $magic callback";
 137      $desc .= ' and dieing' if $die;
 138
 139      my $wiz;
 140      my $code = $dispell
 141                 ? sub { &dispell($_[0], $wiz);    die 'oops' if $die; return }
 142                 : sub { &cast($_[0], $other_wiz); die 'oops' if $die; return };
 143      $wiz = wizard(
 144       data   => sub { 'xyz' },
 145       $magic => $code,
 146      );
 147
 148      my ($var, $res, $err);
 149      if ($magic eq 'free') {
 150       eval {
 151        my $v = $ctor->();
 152        &cast($v, $wiz);
 153       };
 154       $err = $@;
 155      } else {
 156       $var = $ctor->();
 157       &cast($var, $wiz);
 158       $res = eval {
 159        $test->[0]->($var);
 160       };
 161       $err = $@;
 162      }
 163
 164      if ($die) {
 165       like $err, qr/^oops at/, "$desc: correct error";
 166       is $res, undef, "$desc: returned undef";
 167      } else {
 168       is $err, '', "$desc: no error";
 169       is_deeply $res, $test->[1], "$desc: returned value";
 170      }
 171      if (not defined $var) {
 172       pass "$desc: meaningless";
 173      } elsif ($dispell) {
 174       my $data = &getdata($var, $wiz);
 175       is $data, undef, "$desc: correctly dispelled";
 176      } else {
 177       my $data = &getdata($var, $other_wiz);
 178       is $data, 'abc', "$desc: correctly cast";
 179      }
 180     }
 181    }
 182   }
 183  }
 184 }
 185
 186 eval q[
 187  use lib 't/lib';
 188  BEGIN { require Variable::Magic::TestDestroyRequired; }
 189 ];
 190 is $@, '', 'wizard destruction at the end of BEGIN-time require doesn\'t panic';