1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 require './test.pl'; 6 set_up_inc('../lib'); 7 require Config; 8} 9 10use v5.36; 11use feature 'class'; 12no warnings 'experimental::class'; 13 14# A legacy-perl class to act as a test helper 15package DestructionNotify { 16 sub new { my $pkg = shift; bless [ @_ ], $pkg } 17 sub DESTROY { my $self = shift; ${ $self->[0] } .= $self->[1] } 18} 19 20{ 21 my $destroyed; 22 my $notifier = DestructionNotify->new( \$destroyed, 1 ); 23 undef $notifier; 24 $destroyed or 25 BAIL_OUT('DestructionNotify does not work'); 26} 27 28{ 29 my $destroyed; 30 31 class Testcase1 { 32 field $x; 33 method x { return $x; } 34 ADJUST { 35 $x = DestructionNotify->new( \$destroyed, "x" ); 36 } 37 38 field $y; 39 field $z; 40 ADJUST { 41 # These in the "wrong" order just to prove to ourselves that it 42 # doesn't matter 43 $z = DestructionNotify->new( \$destroyed, "z" ); 44 $y = DestructionNotify->new( \$destroyed, "y" ); 45 } 46 } 47 48 my $obj = Testcase1->new; 49 ok(!$destroyed, 'Destruction notify not yet triggered'); 50 51 refcount_is $obj, 1, 'Object has one reference'; 52 53 # one in $obj, one stack temporary here 54 refcount_is $obj->x, 2, 'DestructionNotify has two references'; 55 56 undef $obj; 57 is($destroyed, "zyx", 'Destruction notify triggered by object destruction in the correct order'); 58} 59 60done_testing; 61