]> git.vpit.fr Git - perl/modules/Variable-Magic.git/blob - t/15-self.t
Update VPIT::TestHelpers to 15e8aee3
[perl/modules/Variable-Magic.git] / 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 = 18 }
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 SKIP: {
187  skip "Called twice starting from perl 5.24" => 1 if "$]" >= 5.024;
188
189  my $recasted = 0;
190
191  my $wiz2 = wizard;
192  my $wiz1 = wizard free => sub { ++$recasted; &cast($_[0], $wiz2); die 'xxx' };
193
194  local $@;
195  my $res = eval {
196   my $v = do { my $val = 123; \$val };
197   &cast($v, $wiz1);
198  };
199
200  is $recasted, 1, 'recasting free callback called only once';
201 }
202
203 eval q[
204  use lib 't/lib';
205  BEGIN { require Variable::Magic::TestDestroyRequired; }
206 ];
207 is $@, '', 'wizard destruction at the end of BEGIN-time require doesn\'t panic';