Commit | Line | Data |
3fea05b9 |
1 | #============================================================================ |
2 | # |
3 | # Class::Singleton.pm |
4 | # |
5 | # Implementation of a "singleton" module which ensures that a class has |
6 | # only one instance and provides global access to it. For a description |
7 | # of the Singleton class, see "Design Patterns", Gamma et al, Addison- |
8 | # Wesley, 1995, ISBN 0-201-63361-2 |
9 | # |
10 | # Written by Andy Wardley <abw@wardley.org> |
11 | # |
12 | # Copyright (C) 1998-2008 Andy Wardley. All Rights Reserved. |
13 | # Copyright (C) 1998 Canon Research Centre Europe Ltd. |
14 | # |
15 | #============================================================================ |
16 | |
17 | package Class::Singleton; |
18 | require 5.004; |
19 | use strict; |
20 | use warnings; |
21 | |
22 | our $VERSION = 1.4; |
23 | |
24 | |
25 | #======================================================================== |
26 | # |
27 | # instance() |
28 | # |
29 | # Module constructor. Creates an Class::Singleton (or derived) instance |
30 | # if one doesn't already exist. The instance reference is stored in the |
31 | # _instance variable of the $class package. This means that classes |
32 | # derived from Class::Singleton will have the variables defined in *THEIR* |
33 | # package, rather than the Class::Singleton package. The impact of this is |
34 | # that you can create any number of classes derived from Class::Singleton |
35 | # and create a single instance of each one. If the _instance variable |
36 | # was stored in the Class::Singleton package, you could only instantiate |
37 | # *ONE* object of *ANY* class derived from Class::Singleton. The first |
38 | # time the instance is created, the _new_instance() constructor is called |
39 | # which simply returns a reference to a blessed hash. This can be |
40 | # overloaded for custom constructors. Any addtional parameters passed to |
41 | # instance() are forwarded to _new_instance(). |
42 | # |
43 | # Returns a reference to the existing, or a newly created Class::Singleton |
44 | # object. If the _new_instance() method returns an undefined value |
45 | # then the constructer is deemed to have failed. |
46 | # |
47 | #======================================================================== |
48 | |
49 | sub instance { |
50 | my $class = shift; |
51 | |
52 | # already got an object |
53 | return $class if ref $class; |
54 | |
55 | # we store the instance in the _instance variable in the $class package. |
56 | no strict 'refs'; |
57 | my $instance = \${ "$class\::_instance" }; |
58 | defined $$instance |
59 | ? $$instance |
60 | : ($$instance = $class->_new_instance(@_)); |
61 | } |
62 | |
63 | |
64 | #======================================================================= |
65 | # has_instance() |
66 | # |
67 | # Public method to return the current instance if it exists. |
68 | #======================================================================= |
69 | |
70 | sub has_instance { |
71 | my $class = shift; |
72 | $class = ref $class || $class; |
73 | no strict 'refs'; |
74 | return ${"$class\::_instance"}; |
75 | } |
76 | |
77 | |
78 | #======================================================================== |
79 | # _new_instance(...) |
80 | # |
81 | # Simple constructor which returns a hash reference blessed into the |
82 | # current class. May be overloaded to create non-hash objects or |
83 | # handle any specific initialisation required. |
84 | #======================================================================== |
85 | |
86 | sub _new_instance { |
87 | my $class = shift; |
88 | my %args = @_ && ref $_[0] eq 'HASH' ? %{ $_[0] } : @_; |
89 | bless { %args }, $class; |
90 | } |
91 | |
92 | |
93 | |
94 | 1; |
95 | |
96 | __END__ |
97 | |
98 | =head1 NAME |
99 | |
100 | Class::Singleton - Implementation of a "Singleton" class |
101 | |
102 | =head1 SYNOPSIS |
103 | |
104 | use Class::Singleton; |
105 | |
106 | my $one = Class::Singleton->instance(); # returns a new instance |
107 | my $two = Class::Singleton->instance(); # returns same instance |
108 | |
109 | =head1 DESCRIPTION |
110 | |
111 | This is the C<Class::Singleton> module. A Singleton describes an object class |
112 | that can have only one instance in any system. An example of a Singleton |
113 | might be a print spooler or system registry. This module implements a |
114 | Singleton class from which other classes can be derived. By itself, the |
115 | C<Class::Singleton> module does very little other than manage the instantiation |
116 | of a single object. In deriving a class from C<Class::Singleton>, your module |
117 | will inherit the Singleton instantiation method and can implement whatever |
118 | specific functionality is required. |
119 | |
120 | For a description and discussion of the Singleton class, see |
121 | "Design Patterns", Gamma et al, Addison-Wesley, 1995, ISBN 0-201-63361-2. |
122 | |
123 | =head1 PREREQUISITES |
124 | |
125 | C<Class::Singleton> requires Perl version 5.004 or later. If you have an older |
126 | version of Perl, please upgrade to latest version, available from your nearest |
127 | CPAN site (see L<INSTALLATION> below). |
128 | |
129 | =head1 INSTALLATION |
130 | |
131 | The C<Class::Singleton> module is available from CPAN. As the 'perlmod' man |
132 | page explains: |
133 | |
134 | CPAN stands for the Comprehensive Perl Archive Network. |
135 | This is a globally replicated collection of all known Perl |
136 | materials, including hundreds of unbunded modules. |
137 | |
138 | [...] |
139 | |
140 | For an up-to-date listing of CPAN sites, see |
141 | http://www.perl.com/perl/ or ftp://ftp.perl.com/perl/ . |
142 | |
143 | The module is available in the following directories: |
144 | |
145 | /modules/by-module/Class/Class-Singleton-<version>.tar.gz |
146 | /authors/id/ABW/Class-Singleton-<version>.tar.gz |
147 | |
148 | C<Class::Singleton> is distributed as a single gzipped tar archive file: |
149 | |
150 | Class-Singleton-<version>.tar.gz |
151 | |
152 | Note that "<version>" represents the current version number, of the |
153 | form "C<1.23>". See L<VERSION> below to determine the current version |
154 | number for C<Class::Singleton>. |
155 | |
156 | Unpack the archive to create an installation directory: |
157 | |
158 | gunzip Class-Singleton-<version>.tar.gz |
159 | tar xvf Class-Singleton-<version>.tar |
160 | |
161 | 'cd' into that directory, make, test and install the module: |
162 | |
163 | cd Class-Singleton-<version> |
164 | perl Makefile.PL |
165 | make |
166 | make test |
167 | make install |
168 | |
169 | The 'C<make install>' will install the module on your system. You may need |
170 | root access to perform this task. If you install the module in a local |
171 | directory (for example, by executing "C<perl Makefile.PL LIB=~/lib>" in the |
172 | above - see C<perldoc MakeMaker> for full details), you will need to ensure |
173 | that the C<PERL5LIB> environment variable is set to include the location, or |
174 | add a line to your scripts explicitly naming the library location: |
175 | |
176 | use lib '/local/path/to/lib'; |
177 | |
178 | =head1 USING THE CLASS::SINGLETON MODULE |
179 | |
180 | To import and use the C<Class::Singleton> module the following line should |
181 | appear in your Perl program: |
182 | |
183 | use Class::Singleton; |
184 | |
185 | The L<instance()> method is used to create a new C<Class::Singleton> instance, |
186 | or return a reference to an existing instance. Using this method, it is only |
187 | possible to have a single instance of the class in any system. |
188 | |
189 | my $highlander = Class::Singleton->instance(); |
190 | |
191 | Assuming that no C<Class::Singleton> object currently exists, this first call |
192 | to L<instance()> will create a new C<Class::Singleton> and return a reference |
193 | to it. Future invocations of L<instance()> will return the same reference. |
194 | |
195 | my $macleod = Class::Singleton->instance(); |
196 | |
197 | In the above example, both C<$highlander> and C<$macleod> contain the same |
198 | reference to a C<Class::Singleton> instance. There can be only one. |
199 | |
200 | =head1 DERIVING SINGLETON CLASSES |
201 | |
202 | A module class may be derived from C<Class::Singleton> and will inherit the |
203 | L<instance()> method that correctly instantiates only one object. |
204 | |
205 | package PrintSpooler; |
206 | use base 'Class::Singleton'; |
207 | |
208 | # derived class specific code |
209 | sub submit_job { |
210 | ... |
211 | } |
212 | |
213 | sub cancel_job { |
214 | ... |
215 | } |
216 | |
217 | The C<PrintSpooler> class defined above could be used as follows: |
218 | |
219 | use PrintSpooler; |
220 | |
221 | my $spooler = PrintSpooler->instance(); |
222 | |
223 | $spooler->submit_job(...); |
224 | |
225 | The L<instance()> method calls the L<_new_instance()> constructor method the |
226 | first and only time a new instance is created. All parameters passed to the |
227 | L<instance()> method are forwarded to L<_new_instance()>. In the base class |
228 | the L<_new_instance()> method returns a blessed reference to a hash array |
229 | containing any arguments passed as either a hash reference or list of named |
230 | parameters. |
231 | |
232 | package MyConfig; |
233 | use base 'Class::Singleton'; |
234 | |
235 | sub foo { |
236 | shift->{ foo }; |
237 | } |
238 | |
239 | sub bar { |
240 | shift->{ bar }; |
241 | } |
242 | |
243 | package main; |
244 | |
245 | # either: hash reference of named parameters |
246 | my $config = MyConfig->instance({ foo => 10, bar => 20 }); |
247 | |
248 | # or: list of named parameters |
249 | my $config = MyConfig->instance( foo => 10, bar => 20 ); |
250 | |
251 | print $config->foo(); # 10 |
252 | print $config->bar(); # 20 |
253 | |
254 | Derived classes may redefine the L<_new_instance()> method to provide more |
255 | specific object initialisation or change the underlying object type (to a list |
256 | reference, for example). |
257 | |
258 | package MyApp::Database; |
259 | use base 'Class::Singleton'; |
260 | use DBI; |
261 | |
262 | # this only gets called the first time instance() is called |
263 | sub _new_instance { |
264 | my $class = shift; |
265 | my $self = bless { }, $class; |
266 | my $db = shift || "myappdb"; |
267 | my $host = shift || "localhost"; |
268 | |
269 | $self->{ DB } = DBI->connect("DBI:mSQL:$db:$host") |
270 | || die "Cannot connect to database: $DBI::errstr"; |
271 | |
272 | # any other initialisation... |
273 | |
274 | return $self; |
275 | } |
276 | |
277 | The above example might be used as follows: |
278 | |
279 | use MyApp::Database; |
280 | |
281 | # first use - database gets initialised |
282 | my $database = MyApp::Database->instance(); |
283 | |
284 | Some time later on in a module far, far away... |
285 | |
286 | package MyApp::FooBar |
287 | use MyApp::Database; |
288 | |
289 | # this FooBar object needs access to the database; the Singleton |
290 | # approach gives a nice wrapper around global variables. |
291 | |
292 | sub new { |
293 | my $class = shift; |
294 | bless { |
295 | database => MyApp::Database->instance(), |
296 | }, $class; |
297 | } |
298 | |
299 | The C<Class::Singleton> L<instance()> method uses a package variable to store |
300 | a reference to any existing instance of the object. This variable, |
301 | "C<_instance>", is coerced into the derived class package rather than the base |
302 | class package. |
303 | |
304 | Thus, in the C<MyApp::Database> example above, the instance variable would |
305 | be: |
306 | |
307 | $MyApp::Database::_instance; |
308 | |
309 | This allows different classes to be derived from C<Class::Singleton> that can |
310 | co-exist in the same system, while still allowing only one instance of any one |
311 | class to exists. For example, it would be possible to derive both |
312 | 'C<PrintSpooler>' and 'C<MyApp::Database>' from C<Class::Singleton> and have a |
313 | single instance of I<each> in a system, rather than a single instance of |
314 | I<either>. |
315 | |
316 | You can use the L<has_instance()> method to find out if a particular class |
317 | already has an instance defined. A reference to the instance is returned or |
318 | C<undef> if none is currently defined. |
319 | |
320 | my $instance = MyApp::Database->has_instance() |
321 | || warn "No instance is defined yet"; |
322 | |
323 | =head1 METHODS |
324 | |
325 | =head2 instance() |
326 | |
327 | This method is called to return a current object instance or create a new |
328 | one by calling L<_new_instance()>. |
329 | |
330 | =head2 has_instance() |
331 | |
332 | This method returns a reference to any existing instance or C<undef> if none |
333 | is defined. |
334 | |
335 | my $testing = MySingleton1->has_instance() |
336 | || warn "No instance defined for MySingleton1"; |
337 | |
338 | =head2 _new_instance() |
339 | |
340 | This "private" method is called by L<instance()> to create a new object |
341 | instance if one doesn't already exist. It is not intended to be called |
342 | directly (although there's nothing to stop you from calling it if you're |
343 | really determined to do so). |
344 | |
345 | It creates a blessed hash reference containing any arguments passed to the |
346 | method as either a hash reference or list of named parameters. |
347 | |
348 | # either: hash reference of named parameters |
349 | my $example1 = MySingleton1->new({ pi => 3.14, e => 2.718 }); |
350 | |
351 | # or: list of named parameters |
352 | my $example2 = MySingleton2->new( pi => 3.14, e => 2.718 ); |
353 | |
354 | It is important to remember that the L<instance()> method will I<only> call |
355 | the I<_new_instance()> method once, so any arguments you pass may be silently |
356 | ignored if an instance already exists. You can use the L<has_instance()> |
357 | method to determine if an instance is already defined. |
358 | |
359 | =head1 AUTHOR |
360 | |
361 | Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> |
362 | |
363 | Thanks to Andreas Koenig for providing some significant speedup patches and |
364 | other ideas. |
365 | |
366 | =head1 VERSION |
367 | |
368 | This is version 1.4, released September 2007 |
369 | |
370 | =head1 COPYRIGHT |
371 | |
372 | Copyright Andy Wardley 1998-2007. All Rights Reserved. |
373 | |
374 | This module is free software; you can redistribute it and/or |
375 | modify it under the same terms as Perl itself. |
376 | |
377 | =cut |