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