r25249 - in /branches/upstream/libclass-singleton-perl: ./ current/ current/Changes current/MANIFEST current/Makefile.PL current/README current/Singleton.pm current/test.pl
dmn at users.alioth.debian.org
dmn at users.alioth.debian.org
Wed Sep 17 19:22:35 UTC 2008
Author: dmn
Date: Wed Sep 17 19:22:32 2008
New Revision: 25249
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=25249
Log:
[svn-inject] Installing original source of libclass-singleton-perl
Added:
branches/upstream/libclass-singleton-perl/
branches/upstream/libclass-singleton-perl/current/
branches/upstream/libclass-singleton-perl/current/Changes
branches/upstream/libclass-singleton-perl/current/MANIFEST
branches/upstream/libclass-singleton-perl/current/Makefile.PL
branches/upstream/libclass-singleton-perl/current/README
branches/upstream/libclass-singleton-perl/current/Singleton.pm (with props)
branches/upstream/libclass-singleton-perl/current/test.pl
Added: branches/upstream/libclass-singleton-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-singleton-perl/current/Changes?rev=25249&op=file
==============================================================================
--- branches/upstream/libclass-singleton-perl/current/Changes (added)
+++ branches/upstream/libclass-singleton-perl/current/Changes Wed Sep 17 19:22:32 2008
@@ -1,0 +1,40 @@
+#------------------------------------------------------------------------
+# Version 1.00 Date: 1998/02/10 09:26:44
+#------------------------------------------------------------------------
+
+* Initial revision
+
+
+#------------------------------------------------------------------------
+# Version 1.01 Date: 1998/02/10 09:40:40
+#------------------------------------------------------------------------
+
+* Minor documentation changes
+
+
+#------------------------------------------------------------------------
+# Version 1.02 Date: 1998/04/16 14:10:16
+#------------------------------------------------------------------------
+
+* Fixed minor typos and corrected example in documentation.
+
+
+#------------------------------------------------------------------------
+# Version 1.03 Date: 1999/01/19 15:57:43
+#------------------------------------------------------------------------
+
+* Incorporated patches from Andreas Koenig to inline calculation of
+ $instance variable. This results in a speedup of around 35%.
+
+* Added _new_instance() constructor which is called the first time
+ _instance() is called. This can be overloaded in derived classes
+ to provide more specific object initialisation.
+
+* Updated documentation accordingly.
+
+
+
+
+
+
+
Added: branches/upstream/libclass-singleton-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-singleton-perl/current/MANIFEST?rev=25249&op=file
==============================================================================
--- branches/upstream/libclass-singleton-perl/current/MANIFEST (added)
+++ branches/upstream/libclass-singleton-perl/current/MANIFEST Wed Sep 17 19:22:32 2008
@@ -1,0 +1,6 @@
+Changes
+MANIFEST
+Makefile.PL
+README
+Singleton.pm
+test.pl
Added: branches/upstream/libclass-singleton-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-singleton-perl/current/Makefile.PL?rev=25249&op=file
==============================================================================
--- branches/upstream/libclass-singleton-perl/current/Makefile.PL (added)
+++ branches/upstream/libclass-singleton-perl/current/Makefile.PL Wed Sep 17 19:22:32 2008
@@ -1,0 +1,7 @@
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ 'NAME' => 'Class::Singleton',
+ 'VERSION_FROM' => 'Singleton.pm', # finds $VERSION
+ 'dist' => { 'COMPRESS' => 'gzip', 'SUFFIX' => 'gz' },
+);
Added: branches/upstream/libclass-singleton-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-singleton-perl/current/README?rev=25249&op=file
==============================================================================
--- branches/upstream/libclass-singleton-perl/current/README (added)
+++ branches/upstream/libclass-singleton-perl/current/README Wed Sep 17 19:22:32 2008
@@ -1,0 +1,251 @@
+NAME
+ Class::Singleton - Implementation of a "Singleton" class
+
+SYNOPSIS
+ use Class::Singleton;
+
+ my $one = Class::Singleton->instance(); # returns a new instance
+ my $two = Class::Singleton->instance(); # returns same instance
+
+DESCRIPTION
+ This is the Class::Singleton module. A Singleton describes an
+ object class that can have only one instance in any system. An
+ example of a Singleton might be a print spooler or system
+ registry. This module implements a Singleton class from which
+ other classes can be derived. By itself, the Class::Singleton
+ module does very little other than manage the instantiation of a
+ single object. In deriving a class from Class::Singleton, your
+ module will inherit the Singleton instantiation method and can
+ implement whatever specific functionality is required.
+
+ For a description and discussion of the Singleton class, see
+ "Design Patterns", Gamma et al, Addison-Wesley, 1995, ISBN 0-
+ 201-63361-2.
+
+PREREQUISITES
+ Class::Singleton requires Perl version 5.004 or later. If you
+ have an older version of Perl, please upgrade to latest version.
+ Perl 5.004 is known to be stable and includes new features and
+ bug fixes over previous versions. Perl itself is available from
+ your nearest CPAN site (see INSTALLATION below).
+
+INSTALLATION
+ The Class::Singleton module is available from CPAN. As the
+ 'perlmod' man page explains:
+
+ CPAN stands for the Comprehensive Perl Archive Network.
+ This is a globally replicated collection of all known Perl
+ materials, including hundreds of unbunded modules.
+
+ [...]
+
+ For an up-to-date listing of CPAN sites, see
+ http://www.perl.com/perl/ or ftp://ftp.perl.com/perl/ .
+
+ The module is available in the following directories:
+
+ /modules/by-module/Class/Class-Singleton-<version>.tar.gz
+ /authors/id/ABW/Class-Singleton-<version>.tar.gz
+
+ For the latest information on Class-Singleton or to download the
+ latest pre-release/beta version of the module, consult the
+ definitive reference:
+
+ http://www.kfs.org/~abw/perl/
+
+ Class::Singleton is distributed as a single gzipped tar archive
+ file:
+
+ Class-Singleton-<version>.tar.gz
+
+ Note that "<version>" represents the current version number, of
+ the form "1.23". See the REVISION manpage below to determine the
+ current version number for Class::Singleton.
+
+ Unpack the archive to create an installation directory:
+
+ gunzip Class-Singleton-<version>.tar.gz
+ tar xvf Class-Singleton-<version>.tar
+
+ 'cd' into that directory, make, test and install the module:
+
+ cd Class-Singleton-<version>
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+ The 'make install' will install the module on your system. You
+ may need root access to perform this task. If you install the
+ module in a local directory (for example, by executing "perl
+ Makefile.PL LIB=~/lib" in the above - see `perldoc MakeMaker'
+ for full details), you will need to ensure that the PERL5LIB
+ environment variable is set to include the location, or add a
+ line to your scripts explicitly naming the library location:
+
+ use lib '/local/path/to/lib';
+
+USING THE CLASS::SINGLETON MODULE
+ To import and use the Class::Singleton module the following line
+ should appear in your Perl script:
+
+ use Class::Singleton;
+
+ The instance() method is used to create a new Class::Singleton
+ instance, or return a reference to an existing instance. Using
+ this method, it is only possible to have a single instance of
+ the class in any system.
+
+ my $highlander = Class::Singleton->instance();
+
+ Assuming that no Class::Singleton object currently exists, this
+ first call to instance() will create a new Class::Singleton and
+ return a reference to it. Future invocations of instance() will
+ return the same reference.
+
+ my $macleod = Class::Singleton->instance();
+
+ In the above example, both $highlander and $macleod contain the
+ same reference to a Class::Singleton instance. There can be only
+ one.
+
+DERIVING SINGLETON CLASSES
+ A module class may be derived from Class::Singleton and will
+ inherit the instance() method that correctly instantiates only
+ one object.
+
+ package PrintSpooler;
+ use vars qw(@ISA);
+ @ISA = qw(Class::Singleton);
+
+ # derived class specific code
+ sub submit_job {
+ ...
+ }
+
+ sub cancel_job {
+ ...
+ }
+
+ The PrintSpooler class defined above could be used as follows:
+
+ use PrintSpooler;
+
+ my $spooler = PrintSpooler->instance();
+
+ $spooler->submit_job(...);
+
+ The instance() method calls the _new_instance() constructor
+ method the first and only time a new instance is created. All
+ parameters passed to the instance() method are forwarded to
+ _new_instance(). In the base class this method returns a blessed
+ reference to an empty hash array. Derived classes may redefine
+ it to provide specific object initialisation or change the
+ underlying object type (to a list reference, for example).
+
+ package MyApp::Database;
+ use vars qw( $ERROR );
+ use base qw( Class::Singleton );
+ use DBI;
+
+ $ERROR = '';
+
+ # this only gets called the first time instance() is called
+ sub _new_instance {
+ my $class = shift;
+ my $self = bless { }, $class;
+ my $db = shift || "myappdb";
+ my $host = shift || "localhost";
+
+ unless (defined ($self->{ DB }
+ = DBI->connect("DBI:mSQL:$db:$host"))) {
+ $ERROR = "Cannot connect to database: $DBI::errstr\n";
+ # return failure;
+ return undef;
+ }
+
+ # any other initialisation...
+
+ # return sucess
+ $self;
+ }
+
+ The above example might be used as follows:
+
+ use MyApp::Database;
+
+ # first use - database gets initialised
+ my $database = MyApp::Database->instance();
+ die $MyApp::Database::ERROR unless defined $database;
+
+ Some time later on in a module far, far away...
+
+ package MyApp::FooBar
+ use MyApp::Database;
+
+ sub new {
+ # usual stuff...
+
+ # this FooBar object needs access to the database; the Singleton
+ # approach gives a nice wrapper around global variables.
+
+ # subsequent use - existing instance gets returned
+ my $database = MyApp::Database->instance();
+
+ # the new() isn't called if an instance already exists,
+ # so the above constructor shouldn't fail, but we check
+ # anyway. One day things might change and this could be the
+ # first call to instance()...
+ die $MyAppDatabase::ERROR unless defined $database;
+
+ # more stuff...
+ }
+
+ The Class::Singleton instance() method uses a package variable
+ to store a reference to any existing instance of the object.
+ This variable, "_instance", is coerced into the derived class
+ package rather than the base class package.
+
+ Thus, in the MyApp::Database example above, the instance
+ variable would be:
+
+ $MyApp::Database::_instance;
+
+ This allows different classes to be derived from
+ Class::Singleton that can co-exist in the same system, while
+ still allowing only one instance of any one class to exists. For
+ example, it would be possible to derive both 'PrintSpooler' and
+ 'MyApp::Database' from Class::Singleton and have a single
+ instance of *each* in a system, rather than a single instance of
+ *either*.
+
+AUTHOR
+ Andy Wardley, `<abw at cre.canon.co.uk>'
+
+ Web Technology Group, Canon Research Centre Europe Ltd.
+
+ Thanks to Andreas Koenig `<andreas.koenig at anima.de>' for
+ providing some significant speedup patches and other ideas.
+
+REVISION
+ $Revision: 1.3 $
+
+COPYRIGHT
+ Copyright (C) 1998 Canon Research Centre Europe Ltd. All Rights
+ Reserved.
+
+ This module is free software; you can redistribute it and/or
+ modify it under the term of the Perl Artistic License.
+
+SEE ALSO
+ Canon Research Centre Europe Perl Pages
+ http://www.cre.canon.co.uk/perl/
+
+ The Author's Home Page
+ http://www.kfs.org/~abw/
+
+ Design Patterns
+ Class::Singleton is an implementation of the Singleton class
+ described in "Design Patterns", Gamma et al, Addison-Wesley,
+ 1995, ISBN 0-201-63361-2
+
Added: branches/upstream/libclass-singleton-perl/current/Singleton.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-singleton-perl/current/Singleton.pm?rev=25249&op=file
==============================================================================
--- branches/upstream/libclass-singleton-perl/current/Singleton.pm (added)
+++ branches/upstream/libclass-singleton-perl/current/Singleton.pm Wed Sep 17 19:22:32 2008
@@ -1,0 +1,352 @@
+#============================================================================
+#
+# Class::Singleton.pm
+#
+# Implementation of a "singleton" module which ensures that a class has
+# only one instance and provides global access to it. For a description
+# of the Singleton class, see "Design Patterns", Gamma et al, Addison-
+# Wesley, 1995, ISBN 0-201-63361-2
+#
+# Written by Andy Wardley <abw at cre.canon.co.uk>
+#
+# Copyright (C) 1998 Canon Research Centre Europe Ltd. All Rights Reserved.
+#
+#----------------------------------------------------------------------------
+#
+# $Id: Singleton.pm,v 1.3 1999/01/19 15:57:43 abw Exp $
+#
+#============================================================================
+
+package Class::Singleton;
+
+require 5.004;
+
+use strict;
+use vars qw( $RCS_ID $VERSION );
+
+$VERSION = sprintf("%d.%02d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/);
+$RCS_ID = q$Id: Singleton.pm,v 1.3 1999/01/19 15:57:43 abw Exp $;
+
+
+
+#========================================================================
+# ----- PUBLIC METHODS -----
+#========================================================================
+
+#========================================================================
+#
+# instance()
+#
+# Module constructor. Creates an Class::Singleton (or derivative) instance
+# if one doesn't already exist. The instance reference is stored in the
+# _instance variable of the $class package. This means that classes
+# derived from Class::Singleton will have the variables defined in *THEIR*
+# package, rather than the Class::Singleton package. The impact of this is
+# that you can create any number of classes derived from Class::Singleton
+# and create a single instance of each one. If the _instance variable
+# was stored in the Class::Singleton package, you could only instantiate
+# *ONE* object of *ANY* class derived from Class::Singleton. The first
+# time the instance is created, the _new_instance() constructor is called
+# which simply returns a reference to a blessed hash. This can be
+# overloaded for custom constructors. Any addtional parameters passed to
+# instance() are forwarded to _new_instance().
+#
+# Returns a reference to the existing, or a newly created Class::Singleton
+# object. If the _new_instance() method returns an undefined value
+# then the constructer is deemed to have failed.
+#
+#========================================================================
+
+sub instance {
+ my $class = shift;
+
+ # get a reference to the _instance variable in the $class package
+ no strict 'refs';
+ my $instance = \${ "$class\::_instance" };
+
+ defined $$instance
+ ? $$instance
+ : ($$instance = $class->_new_instance(@_));
+}
+
+
+
+#========================================================================
+#
+# _new_instance(...)
+#
+# Simple constructor which returns a hash reference blessed into the
+# current class. May be overloaded to create non-hash objects or
+# handle any specific initialisation required.
+#
+# Returns a reference to the blessed hash.
+#
+#========================================================================
+
+sub _new_instance {
+ bless { }, $_[0];
+}
+
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+Class::Singleton - Implementation of a "Singleton" class
+
+=head1 SYNOPSIS
+
+ use Class::Singleton;
+
+ my $one = Class::Singleton->instance(); # returns a new instance
+ my $two = Class::Singleton->instance(); # returns same instance
+
+=head1 DESCRIPTION
+
+This is the Class::Singleton module. A Singleton describes an object class
+that can have only one instance in any system. An example of a Singleton
+might be a print spooler or system registry. This module implements a
+Singleton class from which other classes can be derived. By itself, the
+Class::Singleton module does very little other than manage the instantiation
+of a single object. In deriving a class from Class::Singleton, your module
+will inherit the Singleton instantiation method and can implement whatever
+specific functionality is required.
+
+For a description and discussion of the Singleton class, see
+"Design Patterns", Gamma et al, Addison-Wesley, 1995, ISBN 0-201-63361-2.
+
+=head1 PREREQUISITES
+
+Class::Singleton requires Perl version 5.004 or later. If you have an older
+version of Perl, please upgrade to latest version. Perl 5.004 is known
+to be stable and includes new features and bug fixes over previous
+versions. Perl itself is available from your nearest CPAN site (see
+INSTALLATION below).
+
+=head1 INSTALLATION
+
+The Class::Singleton module is available from CPAN. As the 'perlmod' man
+page explains:
+
+ CPAN stands for the Comprehensive Perl Archive Network.
+ This is a globally replicated collection of all known Perl
+ materials, including hundreds of unbunded modules.
+
+ [...]
+
+ For an up-to-date listing of CPAN sites, see
+ http://www.perl.com/perl/ or ftp://ftp.perl.com/perl/ .
+
+The module is available in the following directories:
+
+ /modules/by-module/Class/Class-Singleton-<version>.tar.gz
+ /authors/id/ABW/Class-Singleton-<version>.tar.gz
+
+For the latest information on Class-Singleton or to download the latest
+pre-release/beta version of the module, consult the definitive reference:
+
+ http://www.kfs.org/~abw/perl/
+
+Class::Singleton is distributed as a single gzipped tar archive file:
+
+ Class-Singleton-<version>.tar.gz
+
+Note that "<version>" represents the current version number, of the
+form "1.23". See L<REVISION> below to determine the current version
+number for Class::Singleton.
+
+Unpack the archive to create an installation directory:
+
+ gunzip Class-Singleton-<version>.tar.gz
+ tar xvf Class-Singleton-<version>.tar
+
+'cd' into that directory, make, test and install the module:
+
+ cd Class-Singleton-<version>
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+The 'make install' will install the module on your system. You may need
+root access to perform this task. If you install the module in a local
+directory (for example, by executing "perl Makefile.PL LIB=~/lib" in the
+above - see C<perldoc MakeMaker> for full details), you will need to ensure
+that the PERL5LIB environment variable is set to include the location, or
+add a line to your scripts explicitly naming the library location:
+
+ use lib '/local/path/to/lib';
+
+=head1 USING THE CLASS::SINGLETON MODULE
+
+To import and use the Class::Singleton module the following line should
+appear in your Perl script:
+
+ use Class::Singleton;
+
+The instance() method is used to create a new Class::Singleton instance,
+or return a reference to an existing instance. Using this method, it
+is only possible to have a single instance of the class in any system.
+
+ my $highlander = Class::Singleton->instance();
+
+Assuming that no Class::Singleton object currently exists, this first
+call to instance() will create a new Class::Singleton and return a reference
+to it. Future invocations of instance() will return the same reference.
+
+ my $macleod = Class::Singleton->instance();
+
+In the above example, both $highlander and $macleod contain the same
+reference to a Class::Singleton instance. There can be only one.
+
+=head1 DERIVING SINGLETON CLASSES
+
+A module class may be derived from Class::Singleton and will inherit the
+instance() method that correctly instantiates only one object.
+
+ package PrintSpooler;
+ use vars qw(@ISA);
+ @ISA = qw(Class::Singleton);
+
+ # derived class specific code
+ sub submit_job {
+ ...
+ }
+
+ sub cancel_job {
+ ...
+ }
+
+The PrintSpooler class defined above could be used as follows:
+
+ use PrintSpooler;
+
+ my $spooler = PrintSpooler->instance();
+
+ $spooler->submit_job(...);
+
+The instance() method calls the _new_instance() constructor method the
+first and only time a new instance is created. All parameters passed to
+the instance() method are forwarded to _new_instance(). In the base class
+this method returns a blessed reference to an empty hash array. Derived
+classes may redefine it to provide specific object initialisation or change
+the underlying object type (to a list reference, for example).
+
+ package MyApp::Database;
+ use vars qw( $ERROR );
+ use base qw( Class::Singleton );
+ use DBI;
+
+ $ERROR = '';
+
+ # this only gets called the first time instance() is called
+ sub _new_instance {
+ my $class = shift;
+ my $self = bless { }, $class;
+ my $db = shift || "myappdb";
+ my $host = shift || "localhost";
+
+ unless (defined ($self->{ DB }
+ = DBI->connect("DBI:mSQL:$db:$host"))) {
+ $ERROR = "Cannot connect to database: $DBI::errstr\n";
+ # return failure;
+ return undef;
+ }
+
+ # any other initialisation...
+
+ # return sucess
+ $self;
+ }
+
+The above example might be used as follows:
+
+ use MyApp::Database;
+
+ # first use - database gets initialised
+ my $database = MyApp::Database->instance();
+ die $MyApp::Database::ERROR unless defined $database;
+
+Some time later on in a module far, far away...
+
+ package MyApp::FooBar
+ use MyApp::Database;
+
+ sub new {
+ # usual stuff...
+
+ # this FooBar object needs access to the database; the Singleton
+ # approach gives a nice wrapper around global variables.
+
+ # subsequent use - existing instance gets returned
+ my $database = MyApp::Database->instance();
+
+ # the new() isn't called if an instance already exists,
+ # so the above constructor shouldn't fail, but we check
+ # anyway. One day things might change and this could be the
+ # first call to instance()...
+ die $MyAppDatabase::ERROR unless defined $database;
+
+ # more stuff...
+ }
+
+The Class::Singleton instance() method uses a package variable to store a
+reference to any existing instance of the object. This variable,
+"_instance", is coerced into the derived class package rather than
+the base class package.
+
+Thus, in the MyApp::Database example above, the instance variable would
+be:
+
+ $MyApp::Database::_instance;
+
+This allows different classes to be derived from Class::Singleton that
+can co-exist in the same system, while still allowing only one instance
+of any one class to exists. For example, it would be possible to
+derive both 'PrintSpooler' and 'MyApp::Database' from Class::Singleton and
+have a single instance of I<each> in a system, rather than a single
+instance of I<either>.
+
+=head1 AUTHOR
+
+Andy Wardley, C<E<lt>abw at cre.canon.co.ukE<gt>>
+
+Web Technology Group, Canon Research Centre Europe Ltd.
+
+Thanks to Andreas Koenig C<E<lt>andreas.koenig at anima.deE<gt>> for providing
+some significant speedup patches and other ideas.
+
+=head1 REVISION
+
+$Revision: 1.3 $
+
+=head1 COPYRIGHT
+
+Copyright (C) 1998 Canon Research Centre Europe Ltd. All Rights Reserved.
+
+This module is free software; you can redistribute it and/or modify it under
+the term of the Perl Artistic License.
+
+=head1 SEE ALSO
+
+=over 4
+
+=item Canon Research Centre Europe Perl Pages
+
+http://www.cre.canon.co.uk/perl/
+
+=item The Author's Home Page
+
+http://www.kfs.org/~abw/
+
+=item Design Patterns
+
+Class::Singleton is an implementation of the Singleton class described in
+"Design Patterns", Gamma et al, Addison-Wesley, 1995, ISBN 0-201-63361-2
+
+=back
+
+=cut
Propchange: branches/upstream/libclass-singleton-perl/current/Singleton.pm
------------------------------------------------------------------------------
svn:executable =
Added: branches/upstream/libclass-singleton-perl/current/test.pl
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-singleton-perl/current/test.pl?rev=25249&op=file
==============================================================================
--- branches/upstream/libclass-singleton-perl/current/test.pl (added)
+++ branches/upstream/libclass-singleton-perl/current/test.pl Wed Sep 17 19:22:32 2008
@@ -1,0 +1,252 @@
+#
+# Class::Singleton test script
+#
+# Andy Wardley <abw at cre.canon.co.uk>
+#
+
+BEGIN {
+ $| = 1;
+ print "1..22\n";
+}
+
+END {
+ print "not ok 1\n" unless $loaded;
+}
+
+use Class::Singleton;
+
+$loaded = 1;
+print "ok 1\n";
+
+# turn warnings on
+$^W = 1;
+
+
+
+#========================================================================
+# -- UTILITY SUBS --
+#========================================================================
+
+sub ok {
+ return join('', @_ ? (" ", @_, "\n") : (), "ok ", ++$loaded, "\n");
+}
+
+sub not_ok {
+ return join('', @_ ? (" ", @_, "\n") : (), "not ok ", ++$loaded, "\n");
+}
+
+
+
+#========================================================================
+# -- CLASS DEFINTIONS --
+#========================================================================
+
+#------------------------------------------------------------------------
+# 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';
+
+
+#------------------------------------------------------------------------
+# 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;
+}
+
+
+
+#========================================================================
+# -- TESTS --
+#========================================================================
+
+package main;
+
+# call Class::Singleton->instance() twice and expect to get the same
+# reference returned on both occasions.
+
+my $s1 = Class::Singleton->instance();
+
+#2
+print " Class::Singleton instance 1: ",
+ defined($s1) ? ok($s1) : not_ok('<undef>');
+
+my $s2 = Class::Singleton->instance();
+
+#3
+print " Class::Singleton instance 2: ",
+ (defined($s2) ? ok($s2) : not_ok('<undef>'));
+
+#4
+print $s1 == $s2
+ ? ok('Class::Singleton instances are identical')
+ : not_ok('Class::Singleton instances are unique');
+
+
+# call MySingleton->instance() twice and expect to get the same
+# reference returned on both occasions.
+
+my $s3 = DerivedSingleton->instance();
+
+#5
+print " DerivedSingleton instance 1: ",
+ defined($s3) ? ok($s3) : not_ok('<undef>');
+
+my $s4 = DerivedSingleton->instance();
+
+#6
+print " DerivedSingleton instance 2: ",
+ defined($s4) ? ok($s4) : not_ok('<undef>');
+
+#7
+print $s3 == $s4
+ ? ok("DerivedSingleton instances are identical")
+ : not_ok("DerivedSingleton instances are unique");
+
+
+# call MyOtherSingleton->instance() twice and expect to get the same
+# reference returned on both occasions.
+
+my $s5 = AnotherSingleton->instance();
+
+#8
+print " AnotherSingleton instance 1: ",
+ defined($s5) ? ok($s5) : not_ok('<undef>');
+
+my $s6 = AnotherSingleton->instance();
+
+#9
+print " AnotherSingleton instance 2: ",
+ defined($s6) ? ok($s6) : not_ok('<undef>');
+
+#10
+print $s5 == $s6
+ ? ok("AnotherSingleton instances are identical")
+ : not_ok("AnotherSingleton instances are unique");
+
+
+#------------------------------------------------------------------------
+# 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
+#------------------------------------------------------------------------
+
+#11-13
+print $s1 != $s3
+ ? ok("Class::Singleton and DerviedSingleton are different")
+ : not_ok("Class::Singleton and DerivedSingleton are identical");
+print $s1 != $s5
+ ? ok("Class::Singleton and AnotherSingleton are different")
+ : not_ok("Class::Singleton and AnotherSingleton are identical");
+print $s3 != $s5
+ ? ok("DerivedSingleton and AnotherSingleton are different")
+ : not_ok("DerivedSingleton and AnotherSingleton are identical");
+
+
+
+#------------------------------------------------------------------------
+# test ListSingleton
+#------------------------------------------------------------------------
+
+my $ls1 = ListSingleton->instance();
+my $ls2 = ListSingleton->instance();
+
+#14
+print $ls1
+ ? ok("ListSingleton #1 is defined")
+ : not_ok("ListSingleton #1 is not defined");
+
+#15
+print $ls2
+ ? ok("ListSingleton #2 is defined")
+ : not_ok("ListSingleton #2 is not defined");
+
+#16 - check they are the same reference
+print $ls1 == $ls2
+ ? ok("ListSingleton #1 and #2 correctly reference the same list")
+ : not_ok("ListSingleton #1 and #2 so not reference the same list");
+
+#17 - check it's a LIST reference
+print $ls1 =~ /=ARRAY/
+ ? ok("ListSingleton correctly contains a list reference")
+ : not_ok("ListSingleton does not contain a list reference");
+
+
+
+#------------------------------------------------------------------------
+# test ConfigSingleton
+#------------------------------------------------------------------------
+
+# create a ConfigSingleton
+my $config = { 'foo' => 'This is foo' };
+my $cs1 = ConfigSingleton->instance($config);
+
+# 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);
+
+#18
+print $cs1
+ ? ok("ConfigSingleton #1 is defined")
+ : not_ok("ConfigSingleton #1 is not defined");
+
+#19
+print $cs2
+ ? ok("ConfigSingleton #2 is defined")
+ : not_ok("ConfigSingleton #2 is not defined");
+
+#20 - check they are the same reference
+print $cs1 == $cs2
+ ? ok("ConfigSingleton #1 and #2 correctly reference the same object")
+ : not_ok("ConfigSingleton #1 and #2 so not reference the same object");
+
+#21 - check that 3 keys are defined in $cs1
+print scalar(keys %$cs1) == 3
+ ? ok("ConfigSingleton #1 correctly has 3 keys")
+ : not_ok("ConfigSingleton #1 does not have 3 keys");
+
+#22 - and also in $cs2
+print scalar(keys %$cs2) == 3
+ ? ok("ConfigSingleton #2 correctly has 3 keys")
+ : not_ok("ConfigSingleton #2 does not have 3 keys");
+
+
+
+
+
More information about the Pkg-perl-cvs-commits
mailing list