#!./perl
BEGIN {
chdir
't'
if
-d
't'
;
require
'./test.pl'
;
set_up_inc(
'../lib'
);
}
no
warnings
'experimental::class'
;
sub
new {
my
$pkg
=
shift
;
bless
[
@_
],
$pkg
}
sub
DESTROY {
my
$self
=
shift
; ${
$self
->[0] } .=
$self
->[1] }
}
{
my
$destroyed
;
my
$notifier
= DestructionNotify->new( \
$destroyed
, 1 );
undef
$notifier
;
$destroyed
or
BAIL_OUT(
'DestructionNotify does not work'
);
}
{
my
$destroyed
;
class Testcase1 {
field
$x
;
method x {
return
$x
; }
ADJUST {
$x
= DestructionNotify->new( \
$destroyed
,
"x"
);
}
field
$y
;
field
$z
;
ADJUST {
$z
= DestructionNotify->new( \
$destroyed
,
"z"
);
$y
= DestructionNotify->new( \
$destroyed
,
"y"
);
}
}
my
$obj
= Testcase1->new;
ok(!
$destroyed
,
'Destruction notify not yet triggered'
);
refcount_is
$obj
, 1,
'Object has one reference'
;
refcount_is
$obj
->x, 2,
'DestructionNotify has two references'
;
undef
$obj
;
is(
$destroyed
,
"zyx"
,
'Destruction notify triggered by object destruction in the correct order'
);
}
done_testing;