[libbread-board-perl] 46/66: Add service inheritance sugar
Jonas Smedegaard
js at alioth.debian.org
Sun Sep 29 21:23:38 UTC 2013
This is an automated email from the git hooks/post-receive script.
js pushed a commit to branch master
in repository libbread-board-perl.
commit 02e499ff56fcffdf5b8124c6c2cc3f5871d1ea81
Author: Florian Ragwitz <rafl at debian.org>
Date: Wed Aug 7 11:43:56 2013 -0400
Add service inheritance sugar
---
dist.ini | 2 +-
lib/Bread/Board.pm | 39 ++++++++--
lib/Bread/Board/Literal.pm | 6 ++
lib/Bread/Board/Service.pm | 46 +++++++++++-
t/152_sugar_service_inheritance.t | 149 +++++++++++++++++++++++++++++++++++++
5 files changed, 232 insertions(+), 10 deletions(-)
diff --git a/dist.ini b/dist.ini
index 457802e..639952c 100644
--- a/dist.ini
+++ b/dist.ini
@@ -15,7 +15,7 @@ authority = cpan:STEVAN
[AutoPrereqs]
skip = ^(?:Foo|Bar|Baz|My)\b
-skip = ^(?:Chair|Desk|Employee)\b
+skip = ^(?:Chair|Desk|Employee|Thing)\b
skip = Logger::Role
skip = MyCustomWithParametersService
skip = WorkArea
diff --git a/lib/Bread/Board.pm b/lib/Bread/Board.pm
index 57ab366..ac69204 100644
--- a/lib/Bread/Board.pm
+++ b/lib/Bread/Board.pm
@@ -137,21 +137,44 @@ sub include ($) {
sub service ($@) {
my $name = shift;
my $s;
+
+ my $is_inheriting = ($name =~ s/^\+//);
+
if (scalar @_ == 1) {
+ confess "Service inheritance doesn't make sense for literal services"
+ if $is_inheriting;
+
$s = Bread::Board::Literal->new(name => $name, value => $_[0]);
}
elsif (scalar(@_) % 2 == 0) {
my %params = @_;
- if ($params{service_class}) {
- ($params{service_class}->does('Bread::Board::Service'))
- || confess "The service class must do the Bread::Board::Service role";
- $s = $params{service_class}->new(name => $name, %params);
+
+ my $class = $params{service_class};
+ $class ||= defined $params{service_type} ? "Bread::Board::$params{service_type}Injection"
+ : exists $params{block} ? 'Bread::Board::BlockInjection'
+ : 'Bread::Board::ConstructorInjection';
+
+ $class->does('Bread::Board::Service')
+ or confess "The service class must do the Bread::Board::Service role";
+
+ if ($is_inheriting) {
+ confess "Inheriting services isn't possible outside of the context of a container"
+ unless defined $CC;
+
+ my $prototype_service = $CC->fetch($name);
+
+ confess sprintf(
+ "Trying to inherit from service '%s', but found a %s",
+ $name, blessed $prototype_service,
+ ) unless $prototype_service->does('Bread::Board::Service');
+
+ $s = $prototype_service->clone_and_inherit_params(
+ service_class => $class,
+ %params,
+ );
}
else {
- my $type = $params{service_type};
- $type = exists $params{block} ? 'Block' : 'Constructor'
- unless defined $type;
- $s = "Bread::Board::${type}Injection"->new(name => $name, %params);
+ $s = $class->new(name => $name, %params);
}
}
else {
diff --git a/lib/Bread/Board/Literal.pm b/lib/Bread/Board/Literal.pm
index cfa21c5..e110d5a 100644
--- a/lib/Bread/Board/Literal.pm
+++ b/lib/Bread/Board/Literal.pm
@@ -11,6 +11,10 @@ has 'value' => (
sub get { (shift)->value }
+sub clone_and_inherit_params {
+ confess 'Trying to inherit from a literal service';
+}
+
__PACKAGE__->meta->make_immutable;
no Moose; 1;
@@ -29,6 +33,8 @@ __END__
=item B<value>
+=item B<clone_and_inherit_params>
+
=back
=head1 BUGS
diff --git a/lib/Bread/Board/Service.pm b/lib/Bread/Board/Service.pm
index f8a2ea8..d896f44 100644
--- a/lib/Bread/Board/Service.pm
+++ b/lib/Bread/Board/Service.pm
@@ -1,6 +1,8 @@
package Bread::Board::Service;
use Moose::Role;
+use Moose::Util::TypeConstraints 'find_type_constraint';
+
with 'Bread::Board::Traversable';
has 'name' => (
@@ -63,12 +65,52 @@ sub param {
return;
}
+{
+ my %mergeable_params = (
+ dependencies => {
+ interface => 'Bread::Board::Service::WithDependencies',
+ constraint => 'Bread::Board::Service::Dependencies',
+ },
+ parameters => {
+ interface => 'Bread::Board::Service::WithParameters',
+ constraint => 'Bread::Board::Service::Parameters',
+ },
+ );
+
+ sub clone_and_inherit_params {
+ my ($self, %params) = @_;
+
+ confess "Changing a service's class is not possible when inheriting"
+ unless $params{service_class} eq blessed $self;
+
+ for my $p (keys %mergeable_params) {
+ if (exists $params{$p}) {
+ if ($self->does($mergeable_params{$p}->{interface})) {
+ my $type = find_type_constraint $mergeable_params{$p}->{constraint};
+
+ my $val = $type->assert_coerce($params{$p});
+
+ $params{$p} = {
+ %{ $self->$p },
+ %{ $val },
+ };
+ }
+ else {
+ confess "Trying to add $p to a service not supporting them";
+ }
+ }
+ }
+
+ $self->clone(%params);
+ }
+}
+
requires 'get';
sub lock { (shift)->is_locked(1) }
sub unlock { (shift)->is_locked(0) }
-no Moose::Role; 1;
+no Moose::Util::TypeConstraints; no Moose::Role; 1;
__END__
@@ -96,6 +138,8 @@ __END__
=item B<param>
+=item B<clone_and_inherit_params>
+
=back
=head1 BUGS
diff --git a/t/152_sugar_service_inheritance.t b/t/152_sugar_service_inheritance.t
new file mode 100644
index 0000000..5a502e6
--- /dev/null
+++ b/t/152_sugar_service_inheritance.t
@@ -0,0 +1,149 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Bread::Board;
+
+{
+ package Thing;
+ use Moose;
+
+ has foo => (is => 'ro', required => 1);
+ has moo => (is => 'ro', required => 1);
+
+ no Moose;
+
+ __PACKAGE__->meta->make_immutable;
+}
+
+{
+ package TestThing;
+ use Moose;
+
+ extends 'Thing';
+
+ has bar => (is => 'ro', required => 1);
+ has kooh => (is => 'ro', required => 1);
+
+ no Moose;
+
+ __PACKAGE__->meta->make_immutable;
+}
+
+{
+ my $c = container 'MyApp' => as {
+ service foo => 42;
+
+ service thing => (
+ class => 'Thing',
+ dependencies => [depends_on('foo')],
+ parameters => {
+ moo => { isa => 'Int' },
+ },
+ );
+ };
+
+ {
+ my $t = $c->resolve(
+ service => 'thing',
+ parameters => {
+ moo => 123,
+ },
+ );
+
+ isa_ok $t, 'Thing';
+ is $t->foo, 42;
+ is $t->moo, 123;
+ }
+
+ container $c => as {
+ service bar => 23;
+
+ service '+thing' => (
+ class => 'TestThing',
+ dependencies => [depends_on('bar')],
+ parameters => ['kooh'],
+ );
+ };
+
+ {
+ my $t = $c->resolve(
+ service => 'thing',
+ parameters => {
+ moo => 123,
+ kooh => 456,
+ },
+ );
+
+ isa_ok $t, 'TestThing';
+ is $t->foo, 42;
+ is $t->moo, 123;
+ is $t->bar, 23;
+ is $t->kooh, 456;
+ }
+}
+
+like exception {
+ service '+foo' => 42;
+}, qr/^Service inheritance doesn't make sense for literal services/;
+
+like exception {
+ container Foo => as {
+ container foo => as {};
+ service '+foo' => (block => sub { 42 });
+ };
+}, qr/^Trying to inherit from service 'foo', but found a Bread::Board::Container/;
+
+like exception {
+ container Foo => as {
+ service foo => 42;
+ service '+foo' => (block => sub { 123 });
+ };
+}, qr/^Trying to inherit from a literal service/;
+
+{
+ package Bread::Board::FooInjection;
+ use Moose;
+ extends 'Bread::Board::Literal';
+ no Moose;
+}
+
+like exception {
+ container Foo => as {
+ service foo => (block => sub { 123 });
+ service '+foo' => (service_class => 'Bread::Board::FooInjection');
+ };
+}, qr/^Changing a service's class is not possible when inheriting/;
+
+like exception {
+ container Foo => as {
+ service foo => (block => sub { 123 });
+ service '+foo' => (service_type => 'Foo');
+ };
+}, qr/^Changing a service's class is not possible when inheriting/;
+
+{
+ package Foo;
+ use Moose;
+ no Moose;
+}
+
+like exception {
+ container Foo => as {
+ service foo => (block => sub { 123 });
+ service '+foo' => (class => 'Foo');
+ };
+}, qr/^/;
+
+like exception {
+ container Foo => as {
+ service foo => (class => 'Foo');
+ service '+foo' => (block => sub { 123 });
+ };
+}, qr/^/;
+
+done_testing;
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libbread-board-perl.git
More information about the Pkg-perl-cvs-commits
mailing list