1#!perl 2 3# Based on the test case created by Kevin Ryde for #42502 4 5# All MyObject instances are held in @INSTANCES, only removed by an explicit 6# destroy(). This is like Gtk2::Window from perl-gtk2 where top-level 7# windows are held by gtk in the "list_toplevels" and stay alive until 8# explicitly destroyed. 9 10package MyObject; 11 12use strict; 13use warnings; 14our @INSTANCES; 15 16sub new { 17 my ($class) = @_; 18 my $self = bless { data => ['this is a myobject'] }, $class; 19 push @INSTANCES, $self; 20 return $self; 21} 22 23sub destroy { 24 my ($self) = @_; 25 return ( @INSTANCES = grep { $_ != $self } @INSTANCES ); 26} 27 28package main; 29 30use strict; 31use warnings; 32use Test::Weaken; 33use Test::More tests => 2; 34 35use lib 't/lib'; 36use Test::Weaken::Test; 37 38@INSTANCES = (); 39my $test = Test::Weaken::leaks( 40 sub { MyObject->new }, 41 sub { 42 my ($obj) = @_; 43 $obj->destroy; 44 } 45); 46Test::More::ok( ( !$test ), 'good destructor' ); 47 48@INSTANCES = (); 49$test = Test::Weaken::leaks( sub { return MyObject->new }, sub { } ); 50my $unfreed_count = $test ? $test->unfreed_count() : 0; 51Test::Weaken::Test::is( $unfreed_count, 4, 'no-op destructor' ); 52