1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
|
#
# Class::Singleton test script
#
# Andy Wardley <abw@wardley.org>
#
use 5.008001;
use strict;
use warnings;
use Test::More tests => 29;
use Class::Singleton;
## no critic (Modules::RequireFilenameMatchesPackage)
# the final test is run by a destructor which is called after Test::Builder
# would normally print the test summary, so we disable that
Test::More->builder->no_ending(1);
ok(1, 'loaded Class::Singleton');
#------------------------------------------------------------------------
# define 'DerivedSingleton', a class derived from Class::Singleton
#------------------------------------------------------------------------
package DerivedSingleton;
use base 'Class::Singleton';
#------------------------------------------------------------------------
# define 'AnotherSingleton', a class derived from DerivedSingleton
#------------------------------------------------------------------------
package AnotherSingleton;
use base 'DerivedSingleton';
sub x {
shift->{ x };
}
#------------------------------------------------------------------------
# define 'ListSingleton', which uses a list reference as its type
#------------------------------------------------------------------------
package ListSingleton;
use base 'Class::Singleton';
sub _new_instance {
my $class = shift;
bless [], $class;
}
#------------------------------------------------------------------------
# define 'ConfigSingleton', which has specific configuration needs.
#------------------------------------------------------------------------
package ConfigSingleton;
use base 'Class::Singleton';
sub _new_instance {
my $class = shift;
my $config = shift || { };
my $self = {
'one' => 'This is the first parameter',
'two' => 'This is the second parameter',
%$config,
};
bless $self, $class;
}
#-----------------------------------------------------------------------
# define 'DestructorSingleton' which has a destructor method
#-----------------------------------------------------------------------
package DestructorSingleton;
use base 'Class::Singleton';
sub DESTROY {
main::ok(1, 'destructor called' );
}
#========================================================================
# -- TESTS --
#========================================================================
package main;
# call Class::Singleton->instance() twice and expect to get the same
# reference returned on both occasions.
ok( ! Class::Singleton->has_instance(), 'no Class::Singleton instance yet' );
my $s1 = Class::Singleton->instance();
ok( $s1, 'created Class::Singleton instance 1' );
my $s2 = Class::Singleton->instance();
ok( $s2, 'created Class::Singleton instance 2' );
is( $s1, $s2, 'both instances are the same object' );
is( Class::Singleton->has_instance(), $s1, 'Class::Singleton has instance' );
# call MySingleton->instance() twice and expect to get the same
# reference returned on both occasions.
ok( ! DerivedSingleton->has_instance(), 'no DerivedSingleton instance yet' );
my $s3 = DerivedSingleton->instance();
ok( $s3, 'created DerivedSingleton instance 1' );
my $s4 = DerivedSingleton->instance();
ok( $s4, 'created DerivedSingleton instance 2' );
is( $s3, $s4, 'both derived instances are the same object' );
is( DerivedSingleton->has_instance(), $s3, 'DerivedSingleton has instance' );
# call MyOtherSingleton->instance() twice and expect to get the same
# reference returned on both occasions.
my $s5 = AnotherSingleton->instance( x => 10 );
ok( $s5, 'created AnotherSingleton instance 1' );
is( $s5->x, 10, 'first instance x is 10' );
my $s6 = AnotherSingleton->instance();
ok( $s6, 'created AnotherSingleton instance 2' );
is( $s6->x, 10, 'second instance x is 10' );
is( $s5, $s6, 'both another instances are the same object' );
#------------------------------------------------------------------------
# having checked that each instance of the same class is the same, we now
# check that the instances of the separate classes are actually different
# from each other
#------------------------------------------------------------------------
isnt( $s1, $s3, "Class::Singleton and DerviedSingleton are different");
isnt( $s1, $s5, "Class::Singleton and AnotherSingleton are different");
isnt( $s3, $s5, "DerivedSingleton and AnotherSingleton are different");
#------------------------------------------------------------------------
# test ListSingleton
#------------------------------------------------------------------------
my $ls1 = ListSingleton->instance();
ok( $ls1, 'created ListSingleton instance 1' );
my $ls2 = ListSingleton->instance();
ok( $ls2, 'created ListSingleton instance 2' );
is( $ls1, $ls2, 'both list instances are the same object' );
ok( $ls1 =~ /ARRAY/, "ListSingleton is a list reference");
#------------------------------------------------------------------------
# test ConfigSingleton
#------------------------------------------------------------------------
# create a ConfigSingleton
my $config = { 'foo' => 'This is foo' };
my $cs1 = ConfigSingleton->instance($config);
ok( $cs1, 'created ConfigSingleton instance 1' );
# add another parameter to the config
$config->{'bar'} = 'This is bar';
# shouldn't call new() so changes to $config shouldn't matter
my $cs2 = ConfigSingleton->instance($config);
ok( $cs2, 'created ConfigSingleton instance 2' );
is( $cs1, $cs2, 'both config instances are the same object' );
is( scalar(keys %$cs1), 3, "ConfigSingleton 1 has 3 keys");
is( scalar(keys %$cs2), 3, "ConfigSingleton 2 has 3 keys");
#-----------------------------------------------------------------------
# test DestructorSingleton
#-----------------------------------------------------------------------
my $ds1 = DestructorSingleton->instance();
|
