File Coverage

blib/lib/OOP/Perlish/Class/Multiton.pm

Criterion	Covered	Total	%
statement	36	38	94.7
branch	7	10	70.0
condition	8	15	53.3
subroutine	8	9	88.8
pod			n/a
total	59	72	81.9

#!/usr/bin/perl
use warnings;
use strict;
{
    package OOP::Perlish::Class::Multiton;
    use OOP::Perlish::Class::Singleton;
    use base qw(OOP::Perlish::Class::Singleton);
    use Scalar::Util qw(blessed);

    sub _multiton_key(@) { return '___STUB___' }

    sub _singleton(@)
    {
        my ($self, %opts) = @_;
        my $class = ref($self) || $self;

        my $multiton_name = $opts{$self->_multiton_key()} if( exists( $opts{$self->_multiton_key()} ) );
        return unless($multiton_name);


        no strict 'refs';
        ${ $class . '::____MULTITON_REFS' } = {} unless(defined(${ $class . '::____MULTITON_REFS' }) && ref(${ $class . '::____MULTITON_REFS' }) eq 'HASH');
        my $multiton_refs = ${ $class . '::____MULTITON_REFS' };
        use strict 'refs';


        if( defined($multiton_refs) && ref($multiton_refs) eq 'HASH' && exists( $multiton_refs->{$multiton_name} ) && blessed( $multiton_refs->{$multiton_name} ) ) {
            $self->debug( 'Singleton of ' . $class . ' for key ' . $multiton_name . ' already initialized; NOT reinitialized!!' ) if( scalar keys %opts > 1 );
            return $multiton_refs->{$multiton_name};
        }
        else {
            $multiton_refs->{$multiton_name} = $class->new( %opts, _____oop_perlish_class__initialize_singleton => 1 );
            return $multiton_refs->{$multiton_name};
        }
        return;
    }
}
1;

=head1 NAME
=head1 VERSION
=head1 SYNOPSIS
=head1 EXPORT
=head1 FUNCTIONS
=head1 AUTHOR
=head1 BUGS
=head1 SUPPORT
=head1 ACKNOWLEDGEMENTS
=head1 COPYRIGHT & LICENSE