13 use Variable::Magic qw<wizard cast dispell getdata MGf_LOCAL VMG_UVAR>;
16 use Variable::Magic::TestGlobalDestruction;
22 wizard data => sub { $_[0] },
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');
30 my $res = eval { cast $wiz, $wiz };
31 is($@, '', 'cast on self doesn\'t croak');
32 ok($res, 'cast on self is valid');
35 is($c, 1, 'magic works correctly on self');
37 $res = eval { dispell $wiz, $wiz };
38 is($@, '', 'dispell on self doesn\'t croak');
39 ok($res, 'dispell on self is valid');
42 is($c, 1, 'magic is no longer invoked on self when dispelled');
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');
48 $w = getdata $wiz, $wiz;
49 is($c, 1, 'getdata on magical self doesn\'t trigger callbacks');
51 $res = eval { dispell $wiz, $wiz };
52 is($@, '', 're-dispell on self doesn\'t croak');
53 ok($res, 're-dispell on self is valid');
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');
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;
74 ctor => sub { my $val = 123; \$val },
76 get => [ sub { my $val = ${$_[0]} } => 123 ],
77 set => [ sub { ${$_[0]} = 456; $_[0] } => \456 ],
83 ctor => sub { [ 0 .. 2 ] },
85 len => [ sub { my $len = @{$_[0]} } => 3 ],
86 clear => [ sub { @{$_[0]} = (); $_[0] } => [ ] ],
92 ctor => sub { +{ foo => 'bar' } },
94 clear => [ sub { %{$_[0]} = (); $_[0] } => +{ } ],
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' ],
106 for my $testcases (map $_->{tests}, values %testcases) {
108 while ($i < $#$testcases) {
109 if ($magics{$testcases->[$i]}) {
113 splice @$testcases, $i, 2;
118 $tests += $count * 2 * 2 * 3;
121 my @types = sort { $testcases{$a}->{id} <=> $testcases{$b}->{id} }
124 my $other_wiz = wizard data => sub { 'abc' };
126 for my $type (@types) {
127 my $ctor = $testcases{$type}->{ctor};
129 my @testcases = @{$testcases{$type}->{tests}};
130 while (@testcases >= 2) {
131 my ($magic, $test) = splice @testcases, 0, 2;
133 for my $dispell (0, 1) {
135 my $desc = $dispell ? 'dispell' : 'cast';
136 $desc .= " a $type from a $magic callback";
137 $desc .= ' and dieing' if $die;
141 ? sub { &dispell($_[0], $wiz); die 'oops' if $die; return }
142 : sub { &cast($_[0], $other_wiz); die 'oops' if $die; return };
144 data => sub { 'xyz' },
148 my ($var, $res, $err);
149 if ($magic eq 'free') {
165 like $err, qr/^oops at/, "$desc: correct error";
166 is $res, undef, "$desc: returned undef";
168 is $err, '', "$desc: no error";
169 is_deeply $res, $test->[1], "$desc: returned value";
171 if (not defined $var) {
172 pass "$desc: meaningless";
174 my $data = &getdata($var, $wiz);
175 is $data, undef, "$desc: correctly dispelled";
177 my $data = &getdata($var, $other_wiz);
178 is $data, 'abc', "$desc: correctly cast";
187 skip "Called twice starting from perl 5.24" => 1 if "$]" >= 5.024;
192 my $wiz1 = wizard free => sub { ++$recasted; &cast($_[0], $wiz2); die 'xxx' };
196 my $v = do { my $val = 123; \$val };
200 is $recasted, 1, 'recasting free callback called only once';
205 BEGIN { require Variable::Magic::TestDestroyRequired; }
207 is $@, '', 'wizard destruction at the end of BEGIN-time require doesn\'t panic';