use strict;
use warnings;

package Simple::Factory;

#ABSTRACT: simple factory

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

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',
        _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 on_error => ( 
    is => 'ro', 
    isa => CodeRef, 
    default => sub { "fallback" }, 
    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 ("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} ); 
                }
            }
            default {
                carp "can't coerce on_error '$on_error', please use: carp, croak or fallback";
            }
        }
    }
);

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,
            }
        }
    }

    \%hash_args;
}

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

    $self->_coerce_build_method;
}

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) && $self->has_cache ) {

        # 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);
    }

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

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

    if ( $self->has_cache ) {
        my $instance = $self->cache->get($key);
        return $instance->[0] if defined($instance);
    }

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

    if ( $self->has_cache ) {
        $instance = $self->cache->set( $key => [$instance] )->[0];
    }

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

    return $instance;
};

1;

__END__ 

=head1 NAME

Simple::Factory - a simple factory to create objects easily, with cache, autoderef and fallback supports

=head1 SYNOPSYS

    use Simple::Factory;

    my $factory = Simple::Factory->new(
        'My::Class' => {
            first  => { value => 1 },
            second => [ value => 2 ],
        },
        fallback => { value => undef }, # optional. in absent, will die if find no key
    );

    my $first  = $factory->resolve('first');  # will build a My::Class instance with arguments 'value => 1'
    my $second = $factory->resolve('second'); # will build a My::Class instance with arguments 'value => 2'
    my $last   = $factory->resolve('last');   # will build a My::Class instance with fallback arguments

=head1 DESCRIPTION

This is one way to implement the L<Factory Pattern|http://www.oodesign.com/factory-pattern.html>. The main objective is substitute one hashref of objects ( or coderefs who can build/return objects ) by something more intelligent, who can support caching and fallbacks. If the creation rules are simple we can use C<Simple::Factory> to help us to build instances.

We create instances with C<resolve> method. It is lazy. If you need build all instances (to store in the cache) consider try to resolve them first.

If you need something more complex, consider some framework of Inversion of Control (IoC).

For example, we can create a simple factory to create DateTime objects, using CHI as cache:

   my $factory = Simple::Factory->new(
        build_class  => 'DateTime',
        build_method => 'from_epoch',
        build_conf   => {
            one      => { epoch => 1 },
            two      => { epoch => 2 },
            thousand => { epoch => 1000 }
        },
        fallback => sub { epoch => $_[0] }, # fallback can receive the key
        cache    => CHI->new( driver => 'Memory', global => 1),
    );

  $factory->resolve( 1024 )->epoch # returns 1024

IMPORTANT: if the creation fails ( like some excetion from the constructor ), we will B<not> call the C<fallback>. We expect some error handling from your side.

=head1 ATTRIBUTES

=head2 build_class

Specify the perl package ( class ) used to create instances. Using C<Method::Runtime>, will die if can't load the package.

This argument is required. You can omit by using the C<build_class> as a first argument of the constructor.

=head2 build_args

Specify the mapping of key => arguments, storing in a hashref.

This argument is required. You can omit by using the C<build_class> and C<build_args> as a first pair of arguments.

Important: if C<autoderef> is true, we will try to deref the value before use to create an instance. 

=head2 fallback

The default behavior is die if we try to resolve an instance using one non-existing key.

But if fallback is present, we will use this on the constructor.

If C<autoderef> is true and fallback is a code reference, we will call the code and pass the key as an argument.

=head2 build_method

By default the C<Simple::Factory> calls the method C<new> but you can override and specify your own build method.

Will croak if the C<build_class> does not support the method on C<resolve>.

=head2 autoderef

If true ( default ), we will try to deref the argument present in the C<build_conf> only if it follow this rules:

=over 4

=item * 

will deref only references

=item * 

if the reference is an array, we will call the C<build_method> with C<@$array>.  

=item * 

if the reference is a hash, we will call the C<build_method> with C<%$hash>.

=item * 

if the reference is a scalar or other ref, we will call the C<build_method> with C<$$ref>.

=item * 

if the reference is a glob, we will call the C<build_method> with C<*$glob>.

=item * 

if the reference is a code, we will call the C<build_method> with $code->( $key ) ( same thinf for the fallback )

=item * 

other cases (like Regexes) we will carp if it is not in C<silence> mode. 

=back

=head2 silence

If true ( default is false ), we will omit the carp message if we can't C<autoderef>.

=head2 cache

If present, we will cache the result of the method C<resolve>. The cache should responds to C<get>, C<set> and C<remove> like L<CHI|CHI>.

We will also cache fallback cases.

If we need add a new build_conf via C<add_build_conf_for>, and override one existing configuration, we will remove it from the cache if possible.

default: not present

=head2 inline 

B<Experimental> feature. useful to create multiple inline definitions. See L<resolve>.

This feature can change in the future.

=head2 on_error

Change the default behavior of what happens if build one instance throws on error.

Accepts a coderef. You can also use three initial shortcuts ( will be coerce to coderef ): C<croak>, C<carp> and C<fallback>.

=over 4

=item *

C<croak> will croak the exception + extra message about the key ( B<default> ).

=item *

C<carp> will just carp instead croak and return undef.

=item * 

C<fallback> will resolve the fallback ( but in case of exception will die - to avoid one potential deadlock ).

=back

Example:

    my $factory = Simple::Factory->new(
        Foo => { ... },
        fallback => -1,
        on_error => "fallback" # in case of some exception, call the fallback
    );

If one coderef was used, it will be called with one hashref as argument with three fields:

=over 4

=item * 

C<key> with the value of the key 

=item * 

C<factory> one reference for the factory itself

=item *

C<exception> with the error message

=back

Example:

    my $factory =  Simple::Factory->new(
        Foo => { a => 1 },
        on_error => sub { $logger->warn("error while resolve key '$_[0]->{key}' : '$_[0]->{exception}'; undef },
    );

    $factory->resolve("b"); # will call 'on_error', log the exception and return undef

=head1 METHODS

=head2 add_build_conf_for

usage: add_build_conf_for( key => configuration [, options ])

Can add a new build configuration for one specific key. It is possible add new or just override.

You can change the behavior using an hash of options. 

Options: you can avoid override one existing configuration with C<not_override> and a true value.

Will remove C<cache> if possible.

Example:

    $factory->add_build_conf_for( last => { foo => 1, bar => 2 }); # can override
    $factory->add_build_conf_for( last => { ... }, not_override => 1); # will croak instead override

=head2 resolve

usage: resolve( key [, keys ] )

The main method. Will build one instance of C<build_class> using the C<build_conf> and C<build_method>. 

Should receive a key and if does not exist a C<build_conf> will try use the fallback if specified, or will die ( confess ).

If the C<cache> attribute is present, will try to return first one object from the cache using the C<key>, or will resolve and
store in the cache for the next call.

You can pass multiple keys. If the instance responds to C<resolve> method, we will call with the rest of the keys. It is useful
for inline many factories.

Example:

    my $factory = Simple::Factory->new(
        'Simple::Factory' => {
            Foo => {
                build_class => 'Foo',
                build_conf => {
                    one => 1,
                    two => 2,
                }
            },
            Bar => {
                Bar => {
                    first => { ... },
                    last => { ... },
                }
            }
        }
    );

    my $object = $factory->resolve('Foo', 'one'); # shortcut to ->resolve('Foo')->resolve('one');

Or, using C<inline> experimental option.

    my $factory = Simple::Factory->new(
        'Simple::Factory'=> {
            Foo => { one => 1, two => 2 },
            Bar => { first => 0, last => -1},
        },
        inline => 1,
    );

If we have some exception when we try to create an instance for one particular key, we will not call the C<fallback>. 
We use C<fallback> when we can't find the C<build_conf> based on the key. 

=head2 get_fallback_for_key 

this method will try to resolve the fallback. can be useful on C<on_error> coderefs. accept the same argument as C<resolve>.

=head1 SEE ALSO

=over 4

=item L<Bread::Board|Bread::Board>

A solderless way to wire up your application components.

=item L<IOC|IOC>

A lightweight IOC (Inversion of Control) framework

=back

=head1 AUTHOR

Tiago Peczenyj <tiago (dot) peczenyj (at) gmail (dot) com>

=head1 BUGS

Please report any bugs or feature requests on the bugtracker website
https://github.com/peczenyj/simple-factory-p5/issues

