File Coverage

blib/lib/Simple/Factory.pm

Criterion	Covered	Total	%
statement	101	101	100.0
branch	25	26	96.1
condition	10	12	83.3
subroutine	20	20	100.0
pod	1	3	33.3
total	157	162	96.9

package Simple::Factory;
{
    $Simple::Factory::VERSION = '0.09';
}
use strict;
use warnings;

#ABSTRACT: simple factory

use feature 'switch';
use Carp qw(carp croak confess);
use Module::Runtime qw(use_module);
use Try::Tiny;
use Scalar::Util qw(blessed);

use Moo;
use MooX::HandlesVia;
use MooX::Types::MooseLike::Base qw(HasMethods HashRef Any Bool CodeRef);
use namespace::autoclean;

has build_class => (
    is       => 'ro',
    required => 1,
    coerce   => sub {
        my ($class) = @_;
        use_module($class);
    }
);

has build_conf => (
    is          => 'ro',
    isa         => HashRef [Any],
    required    => 1,
    handles_via => 'Hash',
    handles     => {
        has_build_conf_for  => 'exists',
        get_build_conf_for  => 'get',
        get_supported_keys  => 'keys',
        _add_build_conf_for => 'set',
    }
);

has fallback     => ( is => 'ro', predicate => 1 );
has build_method => ( is => 'ro', default   => sub { "new" } );
has autoderef    => ( is => 'ro', isa       => Bool, default => sub { 1 } );
has silence      => ( is => 'ro', isa       => Bool, default => sub { 0 } );
has cache =>
  ( is => 'ro', isa => HasMethods [qw(get set remove)], predicate => 1 );

has inline => ( is => 'ro', isa => Bool, default => sub { 0 } );
has eager  => ( is => 'ro', isa => Bool, default => sub { 0 } );
has on_error => (
    is      => 'ro',
    isa     => CodeRef,
    default => sub { "croak" },
    coerce  => sub {
        my ($on_error) = @_;

        return $on_error if ref($on_error) eq 'CODE';

        given ($on_error) {
            when ("croak") {
                return sub {
                    my $key = $_[0]->{key};
                    croak "cant resolve instance for key '$key': "
                      . $_[0]->{exception};
                  }
            }
            when ("confess") {
                return sub {
                    my $key = $_[0]->{key};
                    confess "cant resolve instance for key '$key': "
                      . $_[0]->{exception};
                  }
            }
            when ("carp") {
                return sub {
                    my $key = $_[0]->{key};
                    carp "cant resolve instance for key '$key': "
                      . $_[0]->{exception};
                    return;
                  }
            }
            when ("fallback") {
                return sub {
                    return $_[0]->{factory}
                      ->get_fallback_for_key( $_[0]->{key} );
                  }
            }
            when ("undef") {
                return sub { undef }
            }
            default {
                croak
"can't coerce on_error '$on_error', please use: carp, confess, croak, fallback or undef";
            }
        }
    }
);

sub BUILDARGS {
    my ( $self, @args ) = @_;

    if ( scalar(@args) == 1 ) {
        unshift @args, "build_class";
    }
    my (%hash_args) = @args;

    if (   scalar(@args) >= 2
        && !exists $hash_args{build_class}
        && !exists $hash_args{build_conf} )
    {
        my $build_class = $args[0];
        my $build_conf  = $args[1];

        $hash_args{build_class} = $build_class;
        $hash_args{build_conf}  = $build_conf;

        if ( $hash_args{inline} ) {
            $hash_args{build_conf} =
              { map { $_ => { $_ => $build_conf->{$_} } } keys %{$build_conf},
              };
        }
    }

    return \%hash_args;
}

sub BUILD {
    my ($self) = @_;

    $self->_coerce_build_method;

    if ( $self->eager ) {
        $self->resolve($_) for $self->get_supported_keys;
    }

    return;
}

sub _coerce_build_method {
    my ($self) = @_;

    my $class        = $self->build_class;
    my $build_method = $self->build_method;

    my $method = $class->can( $self->build_method )
      or croak
      "Error: class '$class' does not support build method: $build_method";

    return $method;
}

sub _build_object_from_args {
    my ( $self, $args, $key ) = @_;

    my $class  = $self->build_class;
    my $method = $self->_coerce_build_method;

    if ( $self->autoderef && ref($args) ) {
        given ( ref($args) ) {
            when ('ARRAY')  { return $class->$method( @{$args} ); }
            when ('HASH')   { return $class->$method( %{$args} ); }
            when ('SCALAR') { return $class->$method( ${$args} ); }
            when ('REF')    { return $class->$method( ${$args} ); }
            when ('GLOB')   { return $class->$method( *{$args} ); }
            when ('CODE')   { return $class->$method( $args->($key) ); }
            default {
                carp(   "cant autoderef argument ref('"
                      . ref($args)
                      . "') for class '$class'" )
                  if !$self->silence;
            }
        }
    }

    return $class->$method($args);
}

sub get_fallback_for_key {
    my ( $self, $key ) = @_;

    return $self->_build_object_from_args( $self->fallback, $key );
}

sub resolve {
    my ( $self, $key ) = @_;

    my $class = $self->build_class;
    if ( $self->has_build_conf_for($key) ) {
        return try {
            $self->_build_object_from_args( $self->get_build_conf_for($key),
                $key );
        }
        catch {
            $self->on_error->(
                { exception => $_, factory => $self, key => $key } );
        };
    }
    elsif ( $self->has_fallback ) {
        return $self->get_fallback_for_key($key);
    }

    confess("instance of '$class' named '$key' not found");
}

sub add_build_conf_for {
    my ( $self, $key, $conf, %conf ) = @_;

    if ( $self->has_build_conf_for($key) && $conf{not_override} ) {
        croak("cannot override exiting configuration for key '$key'");
    }
    elsif ( $self->has_build_conf_for($key) ) {

        # if we are using cache
        # and we substitute the configuration for some reason
        # we should first remove the cache for this particular key
        $self->_cache_remove($key);
    }

    return $self->_add_build_conf_for( $key => $conf );
}

sub _get_urn_for_cache {
    my ( $self, $key ) = @_;

    join q<:>, $self->build_class, $key;
}

sub _cache_remove {
    my ( $self, $key ) = @_;

    return if !$self->has_cache;

    $self->cache->remove( $self->_get_urn_for_cache($key) );
}

sub _cache_set {
    my ( $self, $key, $value ) = @_;

    return if !$self->has_cache;

    my $urn = $self->_get_urn_for_cache($key);

    $self->cache->set( $urn => $value );
}

sub _cache_get {
    my ( $self, $key ) = @_;

    return if !$self->has_cache;

    my $urn = $self->_get_urn_for_cache($key);

    my $cached = $self->cache->get($urn);

    return $cached if $cached;
}

around [qw(resolve get_fallback_for_key)] => sub {
    my $orig = shift;
    my ( $self, $key, @keys ) = @_;

    my $cached_value = $self->_cache_get($key);

    return $cached_value->[0] if $cached_value;

    my $instance = $self->$orig($key);

    $self->_cache_set( $key => [$instance] );

    if ( scalar(@keys) && $instance->can('resolve') ) {
        return $instance->$orig(@keys);
    }

    return $instance;
};

1;

__END__