File Coverage

blib/lib/Curio/Factory.pm

Criterion	Covered	Total	%
statement	177	197	89.8
branch	59	94	62.7
condition	4	9	44.4
subroutine	52	57	91.2
pod	13	14	92.8
total	305	371	82.2

package Curio::Factory;
our $VERSION = '0.09';

=encoding utf8

=head1 NAME

Curio::Factory - Definer, creator, provider, and holder of Curio objects.

=head1 SYNOPSIS

    my $factory = MyApp::Service::Cache->factory();

=head1 DESCRIPTION

The factory object contains the vast majority of Curio's logic.
Each Curio class (L classes who consume L) gets
a single factory object created for them via L.

Note that much of the example code in this documentation is based
on the L.  Also when you see the term "Curio
object" it is referring to instances of L.

=cut

use Curio::Guard;
use Curio::Util;
use Package::Stash;
use Scalar::Util qw( blessed refaddr );
use Types::Common::String qw( NonEmptySimpleStr );
use Types::Standard qw( Bool Map HashRef Undef );

use Moo;
use strictures 2;
use namespace::clean;

my %class_to_factory;

my $undef_key = '__UNDEF_KEY__';

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

    $self->_store_class_to_factory();
    $self->_install_fetch_method();
    $self->_install_factory_method();

    return;
}

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

    my $class = $self->class();

    croak "Class already has a Curio::Factory object: $class"
        if $class_to_factory{ $class };

    $class_to_factory{ $class } = $self;

    return;
}

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

    Package::Stash->new( $self->class() )->add_symbol(
        '&fetch',
        subname(
            'fetch',
            sub{
                shift;
                return $self->fetch_curio( @_ );
            },
        ),
    );

    return;
}

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

    Package::Stash->new( $self->class() )->add_symbol(
        '&factory',
        subname(
            'factory',
            sub{ $self },
        ),
    );

    return;
}

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

    my $caller_sub_name = (caller 1)[3];
    $caller_sub_name =~ s{^.*::}{};

    my $key;

    if (@$args) {
        $key = shift @$args;
        croak "Invalid key passed to $caller_sub_name()"
            if !NonEmptySimpleStr->check( $key );
    }
    elsif (defined $self->default_key()) {
        $key = $self->default_key();
    }
    else {
        croak "No key was passed to $caller_sub_name()";
    }

    if (!$self->allow_undeclared_keys()) {
        croak "Undeclared key passed to $caller_sub_name()"
            if !$self->_keys->{$key};
    }

    $key = $self->_aliases->{$key}
        if defined( $key )
        and defined( $self->_aliases->{$key} );

    return $key;
}

has _cache => (
    is       => 'ro',
    init_arg => undef,
    default  => sub{ {} },
);

sub _cache_set {
    my ($self, $key, $curio) = @_;
    $key = $self->_fixup_cache_key( $key );
    $self->_cache->{$key} = $curio;
    return;
}

sub _cache_get {
    my ($self, $key) = @_;
    $key = $self->_fixup_cache_key( $key );
    return $self->_cache->{$key};
}

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

    $key = $undef_key if !defined $key;
    return $key if !$self->cache_per_process();

    $key .= "-$$";
    $key .= '-' . threads->tid() if $INC{'threads.pm'};

    return $key;
}

has _registry => (
    is       => 'ro',
    init_arg => undef,
    default  => sub{ {} },
);

has _keys => (
    is       => 'ro',
    init_arg => undef,
    default  => sub{ {} },
);

has _aliases => (
    is       => 'ro',
    init_arg => undef,
    default  => sub{ {} },
);

has _injections => (
    is       => 'ro',
    init_arg => undef,
    default  => sub{ {} },
);

sub _set_injection {
    my ($self, $key, $curio) = @_;
    $key = $self->_fixup_injection_key( $key );
    $self->_injections->{$key} = $curio;
    return;
}

sub _get_injection {
    my ($self, $key) = @_;
    $key = $self->_fixup_injection_key( $key );
    return $self->_injections->{$key};
}

sub _remove_injection {
    my ($self, $key) = @_;
    $key = $self->_fixup_injection_key( $key );
    my $curio = delete $self->_injections->{$key};
    return $curio;
}

sub _fixup_injection_key {
    my ($self, $key) = @_;
    $key = $undef_key if !defined $key;
    return $key;
}

=head1 REQUIRED ARGUMENTS

=head2 class

    class => 'MyApp::Service::Cache',

The Curio class that this factory uses to instantiate Curio
objects.

This is automatically set by L.

=cut

has class => (
    is       => 'ro',
    isa      => NonEmptySimpleStr,
    required => 1,
);

=head1 OPTIONAL ARGUMENTS

=head2 does_registry

    does_registry => 1,
    resource_method_name => 'chi',

Causes the resource of all Curio objects to be automatically
registered so that L may function.

Defaults off (C<0>), meaning L will always return
C.

=cut

has does_registry => (
    is      => 'rw',
    isa     => Bool,
    default => 0,
);

=head2 resource_method_name

    resource_method_name => 'chi',

The method name in the Curio class to retrieve the resource that
it holds.  A resource is whatever "thing" the Curio class
encapsulates.  In the case of the example in L the
resource is the CHI object which is accessible via the C
method.

It is still your job to create the method in the Curio class that
this argument refers to, such as:

    has chi => ( is=>'lazy', ... );

This argument must be defined in order for L and
L to work, otherwise they will have no way
to know how to get at the resource object.

This defaults to the string C.

=cut

has resource_method_name => (
  is      => 'rw',
  isa     => NonEmptySimpleStr,
  default => 'resource',
);

=head2 installs_curio_method

    does_registry => 1,
    resource_method_name => 'chi',
    installs_curio_method => 1,

This causes a C method to be installed in all resource
object classes.  The method calls L and returns it,
allowing for reverse lookups from resource objects to curio objects.

L must be set for this to function.

=cut

has installs_curio_method => (
    is      => 'rw',
    isa     => Bool,
    default => 0,
);

=head2 does_caching

    does_caching => 1,

When caching is enabled all calls to L will attempt to
retrieve from an in-memory cache.

Defaults off (C<0>), meaning all fetch calls will return a new
Curio object.

=cut

has does_caching => (
    is      => 'rw',
    isa     => Bool,
    default => 0,
);

=head2 cache_per_process

    cache_per_process 1,

Some resource objects do not like to be created in one process
and then used in others.  When enabled this will add the current
process's PID and thread ID (if threads are enabled) to the key
used to cache the Curio object.

If either of these process IDs change then fetch will not re-use
the cached Curio object from a different process and will create
a new Curio object under the new process IDs.

Defaults to off (C<0>), meaning the same Curio objects will be
used by fetch across all forks and threads.

Normally the default works fine.  Some L drivers need
this turned on.

=cut

has cache_per_process => (
    is      => 'rw',
    isa     => Bool,
    default => 0,
);

=head2 export_function_name

    export_function_name => 'myapp_cache',

The export function is exported when the the Curio class is
imported, as in:

    use MyApp::Service::Cache;
    my $chi = myapp_cache( $key );

See also L and L.

=cut

has export_function_name => (
    is  => 'rw',
    isa => NonEmptySimpleStr | Undef,
);

=head2 always_export

    always_export => 1,

When enabled this causes the export function to be always exported.

    use MyApp::Service::Cache;

When this option is not set you must explicitly request that the
export function be exported.

    use MyApp::Service::Cache qw( myapp_cache );

=cut

has always_export => (
    is      => 'rw',
    isa     => Bool,
    default => 0,
);

=head2 export_resource

    export_resource => 1,

Rather than returning the curio object this will cause the resource
object to be returned by the export function.  Requires that
L be set.

=cut

has export_resource => (
    is      => 'rw',
    isa     => Bool,
    default => 0,
);

=head2 allow_undeclared_keys

    allow_undeclared_keys => 1,

When L, and other key-accepting methods are called, they
normally throw an exception if the passed key has not already been
declared with L.  By allowing undeclared keys any key
may be passed, which can be useful especially if coupled with
L.

Defaults to off (C<0>), meaning keys must always be declared before
being used.

=cut

has allow_undeclared_keys => (
    is      => 'rw',
    isa     => Bool,
    default => 0,
);

=head2 default_key

    default_key => 'generic',

If no key is passed to key-accepting methods like L then
they will use this default key if available.

Defaults to no default key.

=cut

has default_key => (
    is  => 'rw',
    isa => NonEmptySimpleStr | Undef,
);

=head2 key_argument

    key_argument => 'connection_key',

When set, this causes an extra argument to be passed to the Curio
class during object instantiation.  The argument's key will be
whatever you set C to and the value will be the
key used to fetch the Curio object.

You will still need to write the code in your Curio class to
capture the argument, such as:

    has connection_key => ( is=>'ro' );

Defaults to no key argument.

=cut

has key_argument => (
    is  => 'rw',
    isa => NonEmptySimpleStr | Undef,
);

=head2 default_arguments

    default_arguments => {
        arg => 'value',
        ...
    },

When set, these arguments will be used when creating new instances
of the Curio class.

Any other arguments such as those provided by L and
L will overwrite these default arguments.

=cut

has default_arguments => (
    is      => 'rw',
    isa     => HashRef,
    default => sub{ {} },
);

=head1 ATTRIBUTES

=head2 declared_keys

    my $keys = $factory->declared_keys();
    foreach my $key (@$keys) { ... }

Returns an array ref containing all the keys declared with
L.

=cut

sub declared_keys {
    my ($self) = @_;
    return [ keys %{ $self->_keys() } ];
}

=head1 METHODS

=head2 fetch_curio

    my $curio = $factory->fetch_curio();
    my $curio = $factory->fetch_curio( $key );

Returns a Curio object.  If L is enabled then
a cached object may be returned.

=cut

sub fetch_curio {
    my $self = shift;
    my $key = $self->_process_key_arg( \@_ );
    croak 'Too many arguments passed to fetch_curio()' if @_;

    return $self->_fetch_curio( $key );
}

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

    my $curio;

    $curio = $self->_get_injection( $key );
    return $curio if $curio;

    $curio = $self->_cache_get( $key ) if $self->does_caching();
    return $curio if $curio;

    $curio = $self->_create( $key, {} );

    $self->_cache_set( $key, $curio ) if $self->does_caching();

    return $curio;
}

=head2 fetch_resource

    my $resource = $factory->fetch_resource();
    my $resource = $factory->fetch_resource( $key );

Like L, but always returns a resource.

=cut

sub fetch_resource {
    my $self = shift;
    my $key = $self->_process_key_arg( \@_ );
    croak 'Too many arguments passed to fetch_resource()' if @_;

    return $self->_fetch_resource( $key );
}

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

    my $method = $self->resource_method_name();

    my $curio = $self->_fetch_curio( $key );
    return undef if !$curio->can( $method );

    return $curio->$method();
}

=head2 create

    my $curio = $factory->create( %extra_args );
    my $curio = $factory->create( $key, %extra_args );

Creates a new curio object with arguments gotten from L.  Extra
arguments, which will take precedence, may also be passed.

=cut

sub create {
    my $self = shift;
    my $key = $self->_process_key_arg( \@_ );

    my $extra_args = $self->class->BUILDARGS( @_ );

    return $self->_create( $key, $extra_args );
}

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

    my $args = $self->_arguments( $key );

    my $curio = $self->class->new(
        %$args,
        %$extra_args,
    );

    my $method = $self->resource_method_name();
    if ($curio->can($method)) {
        my $resource = $curio->$method();
        $self->_register_resource( $curio, $resource );

        my $resource_class = blessed $resource;
        $self->_install_curio_method( $resource_class ) if $resource_class;
    }

    return $curio;
}

sub _register_resource {
    my ($self, $curio, $resource) = @_;

    return if !$self->does_registry();
    return if !ref $resource;

    $self->_registry->{ refaddr $resource } = $curio;

    return;
}

sub _install_curio_method {
    my ($self, $resource_class) = @_;

    return if !$self->installs_curio_method();
    return if $resource_class->can('curio');

    no strict 'refs';

    *{"$resource_class\::curio"} = sub{
        my ($resource) = @_;
        return undef if !blessed $resource;
        return $self->find_curio( $resource );
    };

    return;
}

=head2 arguments

    my $args = $factory->arguments();
    my $args = $factory->arguments( $key );

This method returns an arguments hashref that would be used to
instantiate a new Curio object.  You could, for example, use this
to produce a base-line set of arguments, then sprinkle in some
more, and make yourself a special mock object to be injected.

=cut

sub arguments {
    my $self = shift;
    my $key = $self->_process_key_arg( \@_ );
    croak 'Too many arguments passed to arguments()' if @_;

    return $self->_arguments( $key );
}

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

    my $args = { %{ $self->default_arguments() } };

    return $args if !defined $key;

    %$args = (
        %$args,
        %{ $self->_keys->{$key} || {} },
    );

    if (defined $self->key_argument()) {
        $args->{ $self->key_argument() } = $key;
    }

    return $args;
}

=head2 add_key

    $factory->add_key( $key, %arguments );

Declares a new key.

Arguments are optional, but if present they will be saved and used
by L when calling C on L.

=cut

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

    croakf(
        'Invalid key passed to add_key(): %s',
        NonEmptySimpleStr->get_message( $key ),
    ) if !NonEmptySimpleStr->check( $key );

    croak "Already declared key passed to add_key(): $key"
        if $self->_keys->{$key};

    croak 'Odd number of key arguments passed to add_key()'
        if @args % 2 != 0;

    $self->_keys->{$key} = { @args };

    return;
}

=head2 alias_key

    $factory->alias_key( $alias_key => $real_key );

Adds a key that is an alias to a key that was declared with
L.  Alias keys can be used anywhere a declared key
can be used.

=cut

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

    croakf(
        'Invalid alias passed to alias_key(): %s',
        NonEmptySimpleStr->get_message( $alias ),
    ) if !NonEmptySimpleStr->check( $alias );

    croakf(
        'Invalid key passed to alias_key(): %s',
        NonEmptySimpleStr->get_message( $key ),
    ) if !NonEmptySimpleStr->check( $key );

    croak "Already declared alias passed to alias_key(): $alias"
        if defined $self->_aliases->{$alias};

    croak "Undeclared key passed to alias_key(): $key"
        if !$self->allow_undeclared_keys() and !$self->_keys->{$key};

    $self->_aliases->{$alias} = $key;

    return;
}

=head2 find_curio

    my $curio_object = $factory->find_curio( $resource );

Given a Curio object's resource this will return that Curio
object for it.

This does a reverse lookup of sorts and can be useful in
specialized situations where you have the resource, and you
need to introspect back into the Curio object.

    # I have my $chi and nothing else.
    my $factory = MyApp::Service::Cache->factory();
    my $curio = $factory->find_curio( $chi );

This only works if you've enabled L, otherwise
C is always returned by this method.

=cut

sub find_curio {
    my ($self, $resource) = @_;

    croak 'Non-reference resource passed to find_curio()'
        if !ref $resource;

    return $self->_registry->{ refaddr $resource };
}

=head2 inject

    $factory->inject( $curio_object );
    $factory->inject( $key, $curio_object );

Takes a curio object of your making and forces L to
return the injected object (or the injected object's resource).
This is useful for injecting mock objects in tests.

The L method is a good way to make the mock curio object.

=cut

sub inject {
    my $self = shift;
    my $object = (@_>0 and @_<3 and blessed($_[@_-1])) ? pop() : undef;
    croak 'No object passed to inject()' if !$object;
    my $key = $self->_process_key_arg( \@_ );

    $key = $undef_key if !defined $key;

    croak 'Cannot inject a Curio object where one has already been injected'
        if $self->_get_injection( $key );

    $self->_set_injection( $key, $object );

    return;
}

=head2 inject_with_guard

    my $guard = $factory->inject_with_guard(
        $curio_object,
    );

    my $guard = $factory->inject_with_guard(
        $key, $curio_object,
    );

This is just like L except it returns an guard object which,
when it leaves scope and is destroyed, will automatically
L.

=cut

sub inject_with_guard {
    my $self = shift;

    $self->inject( @_ );
    my $key = (@_==1) ? undef : shift( @_ );

    return Curio::Guard->new(sub{
        $self->clear_injection( $key ? $key : () );
    });
}

=head2 clear_injection

    my $curio_object = $factory->clear_injection();
    my $curio_object = $factory->clear_injection( $key );

Removes the previously injected curio object, restoring the original
behavior of L.

Returns the previously injected curio object, or C if there was
not one.

=cut

sub clear_injection {
    my $self = shift;
    my $key = $self->_process_key_arg( \@_ );

    $key = $undef_key if !defined $key;

    my $curio = $self->_remove_injection( $key );

    return $curio;
}

=head2 injection

    my $curio_object = $factory->injection();
    my $curio_object = $factory->injection( $key );

Returns the injected curio object, or C if none has been
injected.

=cut

sub injection {
    my $self = shift;
    my $key = $self->_process_key_arg( \@_ );

    $key = $undef_key if !defined $key;

    return $self->_get_injection( $key );
}

=head2 has_injection

    if ($factory->has_injection()) { ... }
    if ($factory->has_injection( $key )) { ... }

Returns true (C<1>) if an injection is in place.

=cut

sub has_injection {
    my $self = shift;
    my $key = $self->_process_key_arg( \@_ );

    $key = $undef_key if !defined $key;

    return $self->_get_injection( $key ) ? 1 : 0;
}

1;
__END__