view release on metacpan or  search on metacpan

lib/Beam/Wire.pm  view on Meta::CPAN

#pod includes C<$ref>, C<$class>, C<$method>, and etc...
#pod
#pod The default value is C<$>. The empty string is allowed.
#pod
#pod =cut

has meta_prefix => (
    is      => 'ro',
    isa     => Str,
    default => sub { q{$} },
);

#pod =method get
#pod
#pod     my $service = $wire->get( $name );
#pod     my $service = $wire->get( $name, %overrides )
#pod
#pod The get method resolves and returns the service named C<$name>, creating
#pod it, if necessary, with L<the create_service method|/create_service>.
#pod
#pod C<%overrides> is an optional list of name-value pairs. If specified,
#pod get() will create an new, anonymous service that extends the named
#pod service with the given config overrides. For example:
#pod
#pod     # test.pl
#pod     use Beam::Wire;
#pod     my $wire = Beam::Wire->new(
#pod         config => {
#pod             foo => {
#pod                 args => {
#pod                     text => 'Hello, World!',
#pod                 },
#pod             },
#pod         },
#pod     );
#pod
#pod     my $foo = $wire->get( 'foo', args => { text => 'Hello, Chicago!' } );
#pod     print $foo; # prints "Hello, Chicago!"
#pod
#pod This allows you to create factories out of any service, overriding service
#pod configuration at run-time.
#pod
#pod If C<$name> contains a slash (C</>) character (e.g. C<foo/bar>), the left
#pod side (C<foo>) will be used as the name of an inner container, and the
#pod right side (C<bar>) is a service inside that container. For example,
#pod these two lines are equivalent:
#pod
#pod     $bar = $wire->get( 'foo/bar' );
#pod     $bar = $wire->get( 'foo' )->get( 'bar' );
#pod
#pod Inner containers can be nested as deeply as desired (C<foo/bar/baz/fuzz>).
#pod
#pod =cut

sub get {
    my ( $self, $name, %override ) = @_;

    ; print STDERR "Get service: $name\n" if DEBUG;

    if ( index( $name, q{/} ) != -1 ) {
        my ( $container_name, $service_name ) = split m{/}, $name, 2;
        my $container = $self->get( $container_name );

        # This could be a Beam::Wire container, or it could be a plain hashref.
        # If it's a hashref, we can automatically create a container and then use it.
        if (ref $container eq 'HASH' && !(blessed $container and $container->isa('Beam::Wire'))) {
          my $inner_container = Beam::Wire->new(
            config => $container,
          );
          # Do not cache the inner container for later use, in case someone
          # also tries to use the parent as a bare hashref.
          $container = $inner_container;
        }
        return $self->_get_from_inner_container($container, $container_name, $service_name, %override);
    }

    if ( keys %override ) {
        return $self->create_service(
            "\$anonymous extends $name",
            %override,
            extends => $name,
        );
    }

    my $service = $self->services->{$name};
    if ( !$service ) {
        ; printf STDERR 'Service "%s" does not exist. Creating.' . "\n", $name if DEBUG;

        my $config_ref = $self->get_config($name);
        unless ( $config_ref ) {
            Beam::Wire::Exception::NotFound->throw(
                name => $name,
                file => $self->file,
            );
        }

        ; print STDERR "Got service config: " . Dumper( $config_ref ) if DEBUG;

        if ( ref $config_ref eq 'HASH' && $self->is_meta( $config_ref, 1 ) ) {
            my %config  = %{ $self->normalize_config( $config_ref ) };
            $service = $self->create_service( $name, %config );
            if ( !$config{lifecycle} || lc $config{lifecycle} ne 'factory' ) {
                $self->services->{$name} = $service;
            }
        }
        else {
            $self->services->{$name} = $service = $self->find_refs( $name, $config_ref );
        }
    }

    ; print STDERR "Returning service: " . Dumper( $service ) if DEBUG;

    return $service;
}

sub _get_from_inner_container {
  my ($self, $container, $container_name, $service_name, %override) = @_;

  # Bubble up the events from the inner container
  my $unsub_config = $container->on( configure_service => sub {
      my ( $event ) = @_;
      $self->emit( configure_service =>
          class => 'Beam::Wire::Event::ConfigService',
          service_name => join( '/', $container_name, $event->service_name ),
          config => $event->config,
      );
  } );
  my $unsub_build = $container->on( build_service => sub {
      my ( $event ) = @_;
      $self->emit( build_service =>
          class => 'Beam::Wire::Event::BuildService',
          service_name => join( '/', $container_name, $event->service_name ),
          service => $event->service,
      );
  } );

  my $service = $container->get( $service_name, %override );

  $unsub_config->();
  $unsub_build->();

  return $service;
}

#pod =method set
#pod
#pod     $wire->set( $name => $service );
#pod
#pod The set method configures and stores the specified C<$service> with the
#pod specified C<$name>. Use this to add or replace built services.
#pod
#pod Like L<the get() method, above|/get>, C<$name> can contain a slash (C</>)
#pod character to traverse through nested containers.
#pod
#pod =cut

## no critic ( ProhibitAmbiguousNames )
# This was named set() before I started using Perl::Critic, and will
# continue to be named set() now that I no longer use Perl::Critic
sub set {
    my ( $self, $name, $service ) = @_;
    if ( $name =~ q{/} ) {
        my ( $container_name, $service_name ) = split m{/}, $name, 2;
        return $self->get( $container_name )->set( $service_name, $service );
    }
    $self->services->{$name} = $service;
    return;
}

#pod =method get_config
#pod
#pod     my $conf = $wire->get_config( $name );
#pod
#pod Get the config with the given C<$name>. Like L<the get() method,
#pod above|/get>, C<$name> can contain slash (C</>) characters to traverse
#pod through nested containers.
#pod
#pod =cut

sub get_config {
    my ( $self, $name ) = @_;
    if ( $name =~ q{/} ) {
        my ( $container_name, $service ) = split m{/}, $name, 2;
        my %inner_config = %{ $self->get( $container_name )->get_config( $service ) };
        # Fix relative references to prefix the container name
        my ( $fixed_config ) = $self->fix_refs( $container_name, \%inner_config );
        return $fixed_config;
    }
    return $self->config->{$name};
}

#pod =method normalize_config
#pod
#pod     my $out_conf = $self->normalize_config( $in_conf );
#pod
#pod Normalize the given C<$in_conf> into to hash that L<the create_service
#pod method|/create_service> expects. This method allows a service to be
#pod defined with prefixed meta-names (C<$class> instead of C<class>) and
#pod the arguments specified without prefixes.
#pod
#pod For example, these two services are identical.
#pod
#pod     foo:
#pod         class: Foo
#pod         args:
#pod             fizz: buzz
#pod
#pod     foo:
#pod         $class: Foo
#pod         fizz: buzz
#pod
#pod The C<$in_conf> must be a hash, and must already pass L<an is_meta
#pod check|/is_meta>.
#pod
#pod =cut

sub normalize_config {
    my ( $self, $conf ) = @_;

    ; print STDERR "In conf: " . Dumper( $conf ) if DEBUG;

    my %meta = reverse $self->get_meta_names;

    # Confs without prefixed keys can be used as-is
    return $conf if !grep { $meta{ $_ } } keys %$conf;

    my %out_conf;
    for my $key ( keys %$conf ) {
        if ( $meta{ $key } ) {
            $out_conf{ $meta{ $key } } = $conf->{ $key };
        }
        else {
            $out_conf{ args }{ $key } = $conf->{ $key };
        }
    }

    ; print STDERR "Out conf: " . Dumper( \%out_conf ) if DEBUG;

    return \%out_conf;
}

#pod =method create_service
#pod