From 8ad579f26a1c74d5685491df55b57e694e54e087 Mon Sep 17 00:00:00 2001 From: Jesse Luehrs Date: Sun, 20 Feb 2011 02:04:52 -0600 Subject: initial implementation --- dist.ini | 2 + lib/MooseX/Bread/Board.pm | 25 ++++++ lib/MooseX/Bread/Board/BlockInjection.pm | 10 +++ lib/MooseX/Bread/Board/ConstructorInjection.pm | 10 +++ lib/MooseX/Bread/Board/Literal.pm | 10 +++ lib/MooseX/Bread/Board/Meta/Role/Attribute.pm | 109 +++++++++++++++++++++++++ lib/MooseX/Bread/Board/Meta/Role/Class.pm | 19 +++++ lib/MooseX/Bread/Board/Role/Object.pm | 27 ++++++ lib/MooseX/Bread/Board/Role/Service.pm | 32 ++++++++ t/01-basic.t | 79 ++++++++++++++++++ t/02-deps.t | 45 ++++++++++ 11 files changed, 368 insertions(+) create mode 100644 lib/MooseX/Bread/Board/BlockInjection.pm create mode 100644 lib/MooseX/Bread/Board/ConstructorInjection.pm create mode 100644 lib/MooseX/Bread/Board/Literal.pm create mode 100644 lib/MooseX/Bread/Board/Meta/Role/Attribute.pm create mode 100644 lib/MooseX/Bread/Board/Meta/Role/Class.pm create mode 100644 lib/MooseX/Bread/Board/Role/Object.pm create mode 100644 lib/MooseX/Bread/Board/Role/Service.pm create mode 100644 t/01-basic.t create mode 100644 t/02-deps.t diff --git a/dist.ini b/dist.ini index d9964b4..a8bc513 100644 --- a/dist.ini +++ b/dist.ini @@ -7,3 +7,5 @@ copyright_holder = Jesse Luehrs dist = MooseX-Bread-Board [Prereqs] +Moose = 1.21 +Bread::Board = 0 diff --git a/lib/MooseX/Bread/Board.pm b/lib/MooseX/Bread/Board.pm index e69de29..f40797e 100644 --- a/lib/MooseX/Bread/Board.pm +++ b/lib/MooseX/Bread/Board.pm @@ -0,0 +1,25 @@ +package MooseX::Bread::Board; +use Moose::Exporter; + +my (undef, undef, $init_meta) = Moose::Exporter->build_import_methods( + install => ['import', 'unimport'], + class_metaroles => { + attribute => ['MooseX::Bread::Board::Meta::Role::Attribute'], + class => ['MooseX::Bread::Board::Meta::Role::Class'], + }, + base_class_roles => ['MooseX::Bread::Board::Role::Object'], +); + +sub init_meta { + my $package = shift; + my %options = @_; + if (my $meta = Class::MOP::class_of($options{for_class})) { + my @supers = $meta->superclasses; + $meta->superclasses('Bread::Board::Container') + if @supers == 1 && $supers[0] eq 'Moose::Object'; + } + $package->$init_meta(%options); +} + + +1; diff --git a/lib/MooseX/Bread/Board/BlockInjection.pm b/lib/MooseX/Bread/Board/BlockInjection.pm new file mode 100644 index 0000000..e1dca1e --- /dev/null +++ b/lib/MooseX/Bread/Board/BlockInjection.pm @@ -0,0 +1,10 @@ +package MooseX::Bread::Board::BlockInjection; +use Moose; + +extends 'Bread::Board::BlockInjection'; +with 'MooseX::Bread::Board::Role::Service'; + +__PACKAGE__->meta->make_immutable; +no Moose; + +1; diff --git a/lib/MooseX/Bread/Board/ConstructorInjection.pm b/lib/MooseX/Bread/Board/ConstructorInjection.pm new file mode 100644 index 0000000..f3b345b --- /dev/null +++ b/lib/MooseX/Bread/Board/ConstructorInjection.pm @@ -0,0 +1,10 @@ +package MooseX::Bread::Board::ConstructorInjection; +use Moose; + +extends 'Bread::Board::ConstructorInjection'; +with 'MooseX::Bread::Board::Role::Service'; + +__PACKAGE__->meta->make_immutable; +no Moose; + +1; diff --git a/lib/MooseX/Bread/Board/Literal.pm b/lib/MooseX/Bread/Board/Literal.pm new file mode 100644 index 0000000..bf5944a --- /dev/null +++ b/lib/MooseX/Bread/Board/Literal.pm @@ -0,0 +1,10 @@ +package MooseX::Bread::Board::Literal; +use Moose; + +extends 'Bread::Board::Literal'; +with 'MooseX::Bread::Board::Role::Service'; + +__PACKAGE__->meta->make_immutable; +no Moose; + +1; diff --git a/lib/MooseX/Bread/Board/Meta/Role/Attribute.pm b/lib/MooseX/Bread/Board/Meta/Role/Attribute.pm new file mode 100644 index 0000000..a7ecb59 --- /dev/null +++ b/lib/MooseX/Bread/Board/Meta/Role/Attribute.pm @@ -0,0 +1,109 @@ +package MooseX::Bread::Board::Meta::Role::Attribute; +use Moose::Role; + +use Bread::Board::Types; + +use MooseX::Bread::Board::BlockInjection; +use MooseX::Bread::Board::ConstructorInjection; +use MooseX::Bread::Board::Literal; + +has class => ( + is => 'ro', + isa => 'Str', + predicate => 'has_class', +); + +has block => ( + is => 'ro', + isa => 'CodeRef', + predicate => 'has_block', +); + +# has_value is already a method +has literal_value => ( + is => 'ro', + isa => 'Str|CodeRef', + init_arg => 'value', + predicate => 'has_literal_value', +); + +has lifecycle => ( + is => 'ro', + isa => 'Str', + predicate => 'has_lifecycle', +); + +has dependencies => ( + is => 'ro', + isa => 'Bread::Board::Service::Dependencies', + coerce => 1, + predicate => 'has_dependencies', +); + +after attach_to_class => sub { + my $self = shift; + + my $meta = $self->associated_class; + my $attr_reader = $self->get_read_method; + + my %params = ( + associated_attribute => $self, + name => $self->name, + ($self->has_lifecycle + ? (lifecycle => $self->lifecycle) + : ()), + ($self->has_dependencies + ? (dependencies => $self->dependencies) + : ()), + ); + + my $service; + if ($self->has_class) { + $service = MooseX::Bread::Board::ConstructorInjection->new( + %params, + class => $self->class, + ) + } + elsif ($self->has_block) { + $service = MooseX::Bread::Board::BlockInjection->new( + %params, + block => $self->block, + ) + } + elsif ($self->has_literal_value) { + $service = MooseX::Bread::Board::Literal->new( + %params, + value => $self->literal_value, + ) + } + else { + return; + } + + $meta->add_service($service); +}; + +around get_value => sub { + my $orig = shift; + my $self = shift; + my ($instance) = @_; + + return $self->$orig($instance) + if $self->has_value($instance); + + return $instance->get_service($self->name)->get; +}; + +around inline_get => sub { + my $orig = shift; + my $self = shift; + my ($instance) = @_; + + return 'return (' . $self->inline_has($instance) . ')' . "\n" + . '? (' . $self->$orig($instance) . ')' . "\n" + . ': (' . $instance . '->get_service(\'' . $self->name . '\')->get);'; +}; + +no Moose::Role; + +1; diff --git a/lib/MooseX/Bread/Board/Meta/Role/Class.pm b/lib/MooseX/Bread/Board/Meta/Role/Class.pm new file mode 100644 index 0000000..652d0b7 --- /dev/null +++ b/lib/MooseX/Bread/Board/Meta/Role/Class.pm @@ -0,0 +1,19 @@ +package MooseX::Bread::Board::Meta::Role::Class; +use Moose::Role; + +use Bread::Board::Service; + +has services => ( + traits => ['Array'], + isa => 'ArrayRef[Bread::Board::Service]', + default => sub { [] }, + handles => { + add_service => 'push', + services => 'elements', + has_services => 'count', + }, +); + +no Moose::Role; + +1; diff --git a/lib/MooseX/Bread/Board/Role/Object.pm b/lib/MooseX/Bread/Board/Role/Object.pm new file mode 100644 index 0000000..552bc75 --- /dev/null +++ b/lib/MooseX/Bread/Board/Role/Object.pm @@ -0,0 +1,27 @@ +package MooseX::Bread::Board::Role::Object; +use Moose::Role; +use Bread::Board; + +has name => ( + is => 'rw', + isa => 'Str', + lazy => 1, + default => sub { shift->meta->name }, +); + +sub BUILD { } +after BUILD => sub { + my $self = shift; + + my $meta = Class::MOP::class_of($self); + return unless $meta->has_services; + + for my $service ($meta->services) { + $self->add_service($service->clone); + } +}; + +no Bread::Board; +no Moose::Role; + +1; diff --git a/lib/MooseX/Bread/Board/Role/Service.pm b/lib/MooseX/Bread/Board/Role/Service.pm new file mode 100644 index 0000000..8442e3a --- /dev/null +++ b/lib/MooseX/Bread/Board/Role/Service.pm @@ -0,0 +1,32 @@ +package MooseX::Bread::Board::Role::Service; +use Moose::Role; + +has associated_attribute => ( + is => 'ro', + isa => 'Class::MOP::Attribute', + required => 1, + weak_ref => 1, +); + +around get => sub { + my $orig = shift; + my $self = shift; + + my $container = $self; + until (!defined($container) + || ($container->isa('Bread::Board::Container') + && $container->does('MooseX::Bread::Board::Role::Object'))) { + $container = $container->parent; + } + die "Couldn't find associated object!" unless defined $container; + + if ($self->associated_attribute->has_value($container)) { + return $self->associated_attribute->get_value($container); + } + + return $self->$orig(@_); +}; + +no Moose::Role; + +1; diff --git a/t/01-basic.t b/t/01-basic.t new file mode 100644 index 0000000..a679a47 --- /dev/null +++ b/t/01-basic.t @@ -0,0 +1,79 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +{ + package Baz; + use Moose; +} + +{ + package Foo; + use Moose; + use MooseX::Bread::Board; + + has foo => ( + is => 'ro', + isa => 'Str', + default => 'FOO', + ); + + has bar => ( + is => 'ro', + isa => 'Str', + value => 'BAR', + ); + + has baz => ( + is => 'ro', + isa => 'Baz', + class => 'Baz', + ); + + my $i = 0; + has quux => ( + is => 'ro', + isa => 'Str', + block => sub { 'QUUX' . $i++ }, + ); +} + +{ + my $foo = Foo->new; + ok($foo->has_service($_), "has service $_") + for qw(bar baz quux); + ok(!$foo->has_service('foo'), "doesn't have service foo"); + isa_ok($foo->get_service('bar'), 'MooseX::Bread::Board::Literal'); + isa_ok($foo->get_service('baz'), 'MooseX::Bread::Board::ConstructorInjection'); + isa_ok($foo->get_service('quux'), 'MooseX::Bread::Board::BlockInjection'); +} + +{ + my $foo = Foo->new; + is($foo->foo, 'FOO', "normal attrs work"); + is($foo->bar, 'BAR', "literals work"); + isa_ok($foo->baz, 'Baz'); + isnt($foo->baz, $foo->baz, "new instance each time"); + is($foo->quux, 'QUUX0', "block injections work"); + is($foo->quux, 'QUUX1', "and they are run on each access"); +} + +{ + my $baz = Baz->new; + my $foo = Foo->new( + foo => 'OOF', + bar => 'RAB', + baz => $baz, + quux => 'XUUQ', + ); + is($foo->foo, 'OOF', "normal attrs work from constructor"); + is($foo->bar, 'RAB', "constructor overrides literals"); + isa_ok($foo->baz, 'Baz'); + is($foo->baz, $baz, "constructor overrides constructor injections"); + is($foo->baz, $foo->baz, "and returns the same thing each time"); + is($foo->quux, 'XUUQ', "constructor overrides block injections"); + is($foo->quux, 'XUUQ', "and returns the same thing each time"); +} + +done_testing; diff --git a/t/02-deps.t b/t/02-deps.t new file mode 100644 index 0000000..73b3d4a --- /dev/null +++ b/t/02-deps.t @@ -0,0 +1,45 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +{ + package Baz; + use Moose; + + has bar => ( + is => 'ro', + isa => 'Str', + required => 1, + ); +} + +{ + package Foo; + use Moose; + use MooseX::Bread::Board; + + my $i = 0; + has bar => ( + is => 'ro', + isa => 'Str', + block => sub { $i++ }, + ); + + has baz => ( + is => 'ro', + isa => 'Baz', + class => 'Baz', + dependencies => ['bar'], + ); +} + +{ + my $foo = Foo->new; + my $baz = $foo->baz; + is($baz->bar, '0', "deps resolved correctly"); + is($baz->bar, '0', "doesn't re-resolve, since Baz is a normal class"); + is($foo->baz->bar, '1', "re-resolves since the baz attr isn't a singleton"); +} + +done_testing; -- cgit v1.2.3-54-g00ecf