File Coverage

blib/lib/Role/Multiton/New.pm

Criterion	Covered	Total	%
statement	34	34	100.0
branch	6	6	100.0
condition	2	3	66.6
subroutine	6	6	100.0
pod	1	1	100.0
total	49	50	98.0

package Role::Multiton::New;

## no critic (RequireUseStrict) - Role::Tiny does strict
use Role::Tiny;

$Role::Multiton::New::VERSION = '0.2';

use Role::_Multiton ();

sub turn_new_into_multiton {
    my ( $self, @args ) = @_;
    my $class = ref($self);
    die "turn_new_into_multiton() must be called by an object" if !$class;

    no strict 'refs';    ## no critic

    die "turn_new_into_multiton() can not be called after turn_new_into_singleton()" if ${ $class . '::_singleton_orig_new' };

    my $arg_key     = Role::_Multiton::_get_arg_key( \@args );
    my $multiton_hr = Role::_Multiton::_get_multiton_lookup_hr($self);

    if ( ${ $class . '::_multiton_orig_new' } ) {
        $multiton_hr->{$arg_key} = $self;
    }
    else {
        ${ $class . '::_multiton_orig_new' } = \&{ $class . '::new' };
        $multiton_hr->{$arg_key} = $self;

        no warnings 'redefine';
        *{ $class . '::new' } = sub {
            my ( $self, @args ) = @_;
            my $arg_key     = Role::_Multiton::_get_arg_key( \@args );
            my $multiton_hr = Role::_Multiton::_get_multiton_lookup_hr($self);
            return $multiton_hr->{$arg_key} ||= ${ $class . '::_multiton_orig_new' }->( $self, @args );
          }
    }

    return $multiton_hr->{$arg_key};
}

# around 'new' => sub {
#     my ( $orig, $self, @args ) = @_;
#
#     my $arg_key = Role::_Multiton::_get_arg_key( \@args );
#
#     my $multiton_hr = Role::_Multiton::_get_multiton_lookup_hr($self);
#
#     return $multiton_hr->{$arg_key} ||= $orig->( $self, @args );
# };

1;

__END__