164 lines
2.6 KiB
Perl
164 lines
2.6 KiB
Perl
#!perl -T
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use Variable::Magic qw<wizard cast getdata dispell MGf_LOCAL VMG_UVAR>;
|
|
|
|
use Test::More;
|
|
|
|
BEGIN {
|
|
my $tests = 11;
|
|
$tests += 4 * (4 + (MGf_LOCAL ? 1 : 0) + (VMG_UVAR ? 4 : 0));
|
|
plan tests => $tests;
|
|
}
|
|
|
|
our $destroyed;
|
|
|
|
{
|
|
package Variable::Magic::TestDestructor;
|
|
|
|
sub new { bless { }, shift }
|
|
|
|
sub DESTROY { ++$::destroyed }
|
|
}
|
|
|
|
sub D () { 'Variable::Magic::TestDestructor' }
|
|
|
|
{
|
|
local $destroyed = 0;
|
|
|
|
my $w = wizard data => sub { $_[1] };
|
|
|
|
{
|
|
my $obj = D->new;
|
|
|
|
{
|
|
my $x = 1;
|
|
cast $x, $w, $obj;
|
|
is $destroyed, 0;
|
|
}
|
|
|
|
is $destroyed, 0;
|
|
}
|
|
|
|
is $destroyed, 1;
|
|
}
|
|
|
|
{
|
|
local $destroyed = 0;
|
|
|
|
my $w = wizard data => sub { $_[1] };
|
|
|
|
{
|
|
my $copy;
|
|
|
|
{
|
|
my $obj = D->new;
|
|
|
|
{
|
|
my $x = 1;
|
|
cast $x, $w, $obj;
|
|
is $destroyed, 0;
|
|
$copy = getdata $x, $w;
|
|
}
|
|
|
|
is $destroyed, 0;
|
|
}
|
|
|
|
is $destroyed, 0;
|
|
}
|
|
|
|
is $destroyed, 1;
|
|
}
|
|
|
|
{
|
|
local $destroyed = 0;
|
|
|
|
{
|
|
my $obj = D->new;
|
|
|
|
{
|
|
my $w = wizard set => $obj;
|
|
|
|
{
|
|
my $x = 1;
|
|
cast $x, $w;
|
|
is $destroyed, 0;
|
|
}
|
|
|
|
is $destroyed, 0;
|
|
}
|
|
|
|
is $destroyed, 0;
|
|
}
|
|
|
|
is $destroyed, 1;
|
|
}
|
|
|
|
# Test destruction of returned values
|
|
|
|
my @methods = qw<get set clear free>;
|
|
push @methods, 'local' if MGf_LOCAL;
|
|
push @methods, qw<fetch store exists delete> if VMG_UVAR;
|
|
|
|
my %init = (
|
|
scalar_lexical => 'my $x = 1; cast $x, $w',
|
|
scalar_global => 'our $X; local $X = 1; cast $X, $w',
|
|
array => 'my @a = (1); cast @a, $w',
|
|
hash => 'my %h = (a => 1); cast %h, $w',
|
|
);
|
|
|
|
my %type;
|
|
$type{$_} = 'scalar_lexical' for qw<get set free>;
|
|
$type{$_} = 'scalar_global' for qw<local>;
|
|
$type{$_} = 'array' for qw<clear>;
|
|
$type{$_} = 'hash' for qw<fetch store exists delete>;
|
|
|
|
sub void { }
|
|
|
|
my %trigger = (
|
|
get => 'my $y = $x',
|
|
set => '$x = 2',
|
|
clear => '@a = ()',
|
|
free => 'void()',
|
|
local => 'local $X = 2',
|
|
fetch => 'my $v = $h{a}',
|
|
store => '$h{a} = 2',
|
|
exists => 'my $e = exists $h{a}',
|
|
delete => 'my $d = delete $h{a}',
|
|
);
|
|
|
|
for my $meth (@methods) {
|
|
local $destroyed = 0;
|
|
|
|
{
|
|
my $w = wizard $meth => sub { return D->new };
|
|
|
|
my $init = $init{$type{$meth}};
|
|
my $trigger = $trigger{$meth};
|
|
my $deinit = '';
|
|
|
|
if ($meth eq 'free') {
|
|
$init = "{\n$init";
|
|
$deinit = '}';
|
|
}
|
|
|
|
my $code = join ";\n", grep length, (
|
|
$init,
|
|
'is $destroyed, 0, "return from $meth, before trigger"',
|
|
$trigger . ', is($destroyed, 0, "return from $meth, after trigger")',
|
|
$deinit,
|
|
'is $destroyed, 1, "return from $meth, after trigger"',
|
|
);
|
|
|
|
{
|
|
local $@;
|
|
eval $code;
|
|
die $@ if $@;
|
|
}
|
|
|
|
is $destroyed, 1, "return from $meth, end";
|
|
}
|
|
}
|