File Coverage

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

Criterion	Covered	Total	%
statement	36	48	75.0
branch	2	6	33.3
condition	0	9	0.0
subroutine	10	11	90.9
pod			n/a
total	48	74	64.8

#!/usr/bin/perl
use warnings;
use strict;
{

    package OOP::Perlish::Class::Singleton;
    use OOP::Perlish::Class;
    use Scalar::Util qw(blessed);

    use base qw(OOP::Perlish::Class);

    sub _magic_constructor_arg_handler_singleton(@)
    {
        my ( $self, $opts ) = @_;

        my $key = 'return';
        my $singleton;

        ### Handle some magical arguments used for internal purposes
        if( !exists( $opts->{_____oop_perlish_class__initialize_singleton} ) ) {
            $singleton = $self->_singleton( %{$opts} );
            return ( $key, [$singleton] );
        }
        else {
            delete( $opts->{_____oop_perlish_class__initialize_singleton} );
        }
        return;

    }

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

        no strict 'refs';
        my $singleton = ${ $class . '::_SINGLETONREF' };
        use strict 'refs';
        if( defined($singleton) && ref($singleton) && blessed($singleton) ) {
            $singleton->debug( 'Singleton of ' . $class . ' already initialized; NOT reinitialized!!' ) if( scalar keys %opts );
            return $singleton;
        }
        else {
            $singleton = $class->new( %opts, _____oop_perlish_class__initialize_singleton => 1 );
            no strict 'refs';
            ${ $class . '::_SINGLETONREF' } = $singleton;
            use strict 'refs';
            return $singleton;
        }

        return;
    }
}
1;

__END__