1#!/usr/bin/perl 2 3## 4## Tests of main functionality of Object::Destroyer - 5## i.e. destruction of objects - are here. 6## 7 8use strict; 9BEGIN { 10 $| = 1; 11 $^W = 1; 12} 13 14use Test::More tests => 31; 15use Object::Destroyer; 16 17## 18## Make sure a Foo object behaves as expected 19## 20is( $Foo::destroy_counter, 0, 'Start value' ); 21 22SCOPE: { 23 ## 24 ## This object will not be destroyed automatically 25 ## 26 my $foo = Foo->new; 27 is( $Foo::destroy_counter, 0, 'No auto destroy of Foo objects' ); 28} 29 30SCOPE: { 31 ## 32 ## This $foo is destroyed manually 33 ## 34 my $foo = Foo->new; 35 $foo->DESTROY; 36 is( $Foo::destroy_counter, 1, 'Manually called DESTROY' ); 37} 38is( $Foo::destroy_counter, 2, 'Auto called DESTROY after leaving the scope' ); 39 40 41## 42## Foo objects are OK, let's start testing our Object::Destroyer 43## 44 45## 46## Test of default 'DESTROY' method 47## It's called twice - 1st by Object::Destroyer, 2nd by Perl gc! 48## 49SCOPE: { 50 my $foo = Foo->new; 51 my $sentry = Object::Destroyer->new($foo); 52 @Foo::called_method = (); 53} 54is( $Foo::destroy_counter, 4, 'DESTROY called by Object::Destroyer' ); 55is_deeply( \@Foo::called_method, ['DESTROY', 'DESTROY'] ); 56 57## 58## Test that the specified method is called indeed 59## 60SCOPE: { 61 my $foo = Foo->new; 62 my $sentry = Object::Destroyer->new($foo, 'release'); 63 @Foo::called_method = (); 64} 65is( $Foo::destroy_counter, 5, 'release called by Object::Destroyer' ); 66is_deeply( \@Foo::called_method, ['release', 'DESTROY'] ); 67 68SCOPE: { 69 my $foo = Foo->new; 70 my $sentry = Object::Destroyer->new($foo, 'delete'); 71 @Foo::called_method = (); 72} 73is( $Foo::destroy_counter, 6, 'delete called by Object::Destroyer' ); 74is_deeply( \@Foo::called_method, ['delete', 'DESTROY'] ); 75 76 77## 78## Test manual clean-up of the enclosed object 79## by $sentry->DESTROY or undef($sentry) 80## 81SCOPE: { 82 my $foo = Foo->new; 83 my $sentry = Object::Destroyer->new($foo); 84 is( $Foo::destroy_counter, 6, 'nothing changed' ); 85 $sentry->DESTROY; 86 is( $Foo::destroy_counter, 7, 'Foo->DESTROY by Object::Destroyer' ); 87} 88is( $Foo::destroy_counter, 8, 'Foo->DESTROY by Perl gc' ); 89 90SCOPE: { 91 my $foo = Foo->new; 92 my $sentry = Object::Destroyer->new($foo, 'release'); 93 is( $Foo::destroy_counter, 8, 'nothing changed' ); 94 $sentry->DESTROY; 95 is( $Foo::destroy_counter, 8, 'Foo->release (not DESTROY) has not been called' ); 96} 97is( $Foo::destroy_counter, 9, 'Foo->DESTROY by Perl gc' ); 98 99SCOPE: { 100 my $foo = Foo->new; 101 my $sentry = Object::Destroyer->new($foo); 102 is( $Foo::destroy_counter, 9, 'nothing changed' ); 103 undef $sentry; 104 is( $Foo::destroy_counter, 10, 'Foo->DESTROY by Object::Destroyer' ); 105} 106is( $Foo::destroy_counter, 11, 'Foo->DESTROY by Perl gc' ); 107 108SCOPE: { 109 my $foo = Foo->new; 110 my $sentry = Object::Destroyer->new($foo, 'release'); 111 is( $Foo::destroy_counter, 11, 'nothing changed' ); 112 undef $sentry; 113 is( $Foo::destroy_counter, 11, 'Foo->release' ); 114} 115is( $Foo::destroy_counter, 12, 'Foo->DESTROY by Perl gc' ); 116 117 118## 119## Test anonymous subrotine calls 120## 121SCOPE: { 122 my $test = 0; 123 SCOPE: { 124 my $sentry = Object::Destroyer->new( sub{$test=1} ); 125 is($test, 0); 126 } 127 is($test, 1); 128 for ( 1 .. 10 ) { 129 my $sentry = Object::Destroyer->new( sub{$test++} ); 130 } 131 is($test, 11); 132} 133 134## 135## Anonymous subrotine destroys an object not capable of auto-destroy 136## 137is( $Bar::count, 0 ); 138for (0..9) { 139 my $bar = Bar->new; 140} 141is( $Bar::count, 10 ); 142for (0..9) { 143 my $bar = Bar->new; 144 my $sentry = Object::Destroyer->new( sub{undef $bar->{self}} ); 145} 146is( $Bar::count, 10 ); 147 148## 149## Test objects that use Object::Destroy in their constructors 150## 151is( $Buzz::count, 0 ); 152{ 153 my $bar = Buzz->new; 154 is( $Buzz::count, 1 ); 155} 156is( $Buzz::count, 0 ); 157 158 159 160 161 162##################################################################### 163# Test Classes 164 165package Foo; 166 167use vars qw{$destroy_counter @called_method}; 168BEGIN { $destroy_counter = 0 } 169 170sub new { 171 my $class = shift; 172 my $self = {}; 173 $self->{self} = $self; ## circular reference 174 return bless $self, ref $class || $class; 175} 176 177sub delete{ 178 my $self = shift; 179 undef $self->{self}; 180 push @called_method, 'delete'; 181} 182 183sub release { 184 my $self = shift; 185 undef $self->{self}; 186 push @called_method, 'release'; 187} 188 189sub DESTROY { 190 my $self = shift; 191 $destroy_counter++; 192 undef $self->{self}; 193 push @called_method, 'DESTROY'; 194} 195 196## 197## Object of class Bar has no clean-up method at all 198## 199package Bar; 200use vars '$count'; 201BEGIN { $count = 0; } 202 203sub new{ 204 my $class = shift; 205 206 $count++; 207 208 my $self = {}; 209 $self->{self} = $self; 210 return bless $self, ref $class || $class; 211} 212 213sub DESTROY{ 214 $count--; 215} 216 217## 218## Constructor of Buzz returns itself in a wrapper 219## 220package Buzz; 221use vars '$count'; 222BEGIN { $count = 0 }; 223sub new{ 224 my $class = shift; 225 226 $count++; 227 228 my $self = bless {}, ref $class || $class; 229 $self->{self} = $self; 230 return Object::Destroyer->new($self, 'release'); 231} 232 233sub release{ 234 my $self = shift; 235 undef $self->{self}; 236} 237 238sub DESTROY{ 239 my $self = shift; 240 $count--; 241} 242 2431; 244