From 112e56b0bd5e6a6aff3c1d513ad7d0c528e899f7 Mon Sep 17 00:00:00 2001 From: Jesse Luehrs Date: Mon, 10 Oct 2011 12:23:03 -0500 Subject: split this out, so we can have attributes that aren't services --- lib/Bread/Board/Declare.pm | 5 +- lib/Bread/Board/Declare/Meta/Role/Attribute.pm | 294 ++------------------- .../Board/Declare/Meta/Role/Attribute/Service.pm | 291 ++++++++++++++++++++ 3 files changed, 312 insertions(+), 278 deletions(-) create mode 100644 lib/Bread/Board/Declare/Meta/Role/Attribute/Service.pm diff --git a/lib/Bread/Board/Declare.pm b/lib/Bread/Board/Declare.pm index 0d1b6ea..c0b35af 100644 --- a/lib/Bread/Board/Declare.pm +++ b/lib/Bread/Board/Declare.pm @@ -85,8 +85,9 @@ C<< required => 1 >> is still valid on these attributes. Constructor parameters for services (C, C, etc) can also be passed into the attribute definition; these will be forwarded to the -service constructor. See L for -a full list of additional parameters to C. +service constructor. See +L for a full list of +additional parameters to C. If C<< infer => 1 >> is passed in the attribute definition, the class in the type constraint will be introspected to find its required dependencies, and diff --git a/lib/Bread/Board/Declare/Meta/Role/Attribute.pm b/lib/Bread/Board/Declare/Meta/Role/Attribute.pm index 0fddfca..2caeed4 100644 --- a/lib/Bread/Board/Declare/Meta/Role/Attribute.pm +++ b/lib/Bread/Board/Declare/Meta/Role/Attribute.pm @@ -1,291 +1,33 @@ package Bread::Board::Declare::Meta::Role::Attribute; use Moose::Role; -Moose::Util::meta_attribute_alias('Service'); -# ABSTRACT: attribute metarole for Bread::Board::Declare -use Bread::Board::Types; -use List::MoreUtils qw(any); +use List::MoreUtils 'any'; +use Moose::Util 'does_role', 'find_meta'; -use Bread::Board::Declare::BlockInjection; -use Bread::Board::Declare::ConstructorInjection; -use Bread::Board::Declare::Literal; - -=head1 DESCRIPTION - -This role adds functionality to the attribute metaclass for -L objects. - -=cut - -=attr service - -Whether or not to create a service for this attribute. Defaults to true. - -=cut - -has service => ( - is => 'ro', - isa => 'Bool', - default => 1, -); - -=attr block - -The block to use when creating a L service. - -=cut - -has block => ( - is => 'ro', - isa => 'CodeRef', - predicate => 'has_block', -); - -=attr literal_value - -The value to use when creating a L service. Note that -the parameter that should be passed to C is C. - -=cut - -# has_value is already a method -has literal_value => ( - is => 'ro', - isa => 'Value', - init_arg => 'value', - predicate => 'has_literal_value', -); - -=attr lifecycle - -The lifecycle to use when creating the service. See L -and L. - -=cut - -has lifecycle => ( - is => 'ro', - isa => 'Str', - predicate => 'has_lifecycle', -); - -=attr dependencies - -The dependency specification to use when creating the service. See -L. - -=cut - -has dependencies => ( - is => 'ro', - isa => 'Bread::Board::Service::Dependencies', - coerce => 1, - predicate => 'has_dependencies', -); - -=attr parameters - -The parameter specification to use when creating the service. See L. - -=cut - -has parameters => ( - is => 'ro', - isa => 'Bread::Board::Service::Parameters', - coerce => 1, - predicate => 'has_parameters', -); - -=attr infer - -If true, the dependency list will be inferred as much as possible from the -attributes in the class. See L for -more information. Note that this is only valid for constructor injection -services. - -=cut - -has infer => ( - is => 'ro', - isa => 'Bool', -); - -=attr constructor_name - -The constructor name to use when creating L -services. Defaults to C. - -=cut - -has constructor_name => ( - is => 'ro', - isa => 'Str', - predicate => 'has_constructor_name', -); - -=attr associated_service - -The service object that is associated with this attribute. - -=cut - -has associated_service => ( - is => 'rw', - does => 'Bread::Board::Service', - predicate => 'has_associated_service', -); - -after attach_to_class => sub { - my $self = shift; - - return unless $self->service; - - my %params = ( - associated_attribute => $self, - name => $self->name, - ($self->has_lifecycle - ? (lifecycle => $self->lifecycle) - : ()), - ($self->has_dependencies - ? (dependencies => $self->dependencies) - : ()), - ($self->has_parameters - ? (parameters => $self->parameters) - : ()), - ($self->has_constructor_name - ? (constructor_name => $self->constructor_name) - : ()), - ); - - my $tc = $self->has_type_constraint ? $self->type_constraint : undef; - - my $service; - if ($self->has_block) { - if ($tc && $tc->isa('Moose::Meta::TypeConstraint::Class')) { - %params = (%params, class => $tc->class); - Class::MOP::load_class($tc->class); - } - $service = Bread::Board::Declare::BlockInjection->new( - %params, - block => $self->block, - ); - } - elsif ($self->has_literal_value) { - $service = Bread::Board::Declare::Literal->new( - %params, - value => $self->literal_value, - ); - } - elsif ($tc && $tc->isa('Moose::Meta::TypeConstraint::Class')) { - Class::MOP::load_class($tc->class); - $service = Bread::Board::Declare::ConstructorInjection->new( - %params, - class => $tc->class, - ); - } - else { - $service = Bread::Board::Declare::BlockInjection->new( - %params, - block => sub { - die "Attribute " . $self->name . " did not specify a service." - . " It must be given a value through the constructor or" - . " writer method before it can be resolved." - }, - ); - } - - $self->associated_service($service) if $service; -}; - -after _process_options => sub { - my $class = shift; - my ($name, $opts) = @_; - - return unless exists $opts->{default} - || exists $opts->{builder}; - return unless exists $opts->{class} - || exists $opts->{block} - || exists $opts->{value}; - - # XXX: uggggh - return if any { $_ eq 'Moose::Meta::Attribute::Native::Trait::String' - || $_ eq 'Moose::Meta::Attribute::Native::Trait::Counter' } - @{ $opts->{traits} }; - - my $exists = exists($opts->{default}) ? 'default' : 'builder'; - die "$exists is not valid when Bread::Board service options are set"; -}; - -around get_value => sub { +# this is kinda gross, but it's the only way to hook in at the right place +# at the moment, it seems +around interpolate_class => sub { my $orig = shift; - my $self = shift; - my ($instance) = @_; + my $class = shift; + my ($options) = @_; - return $self->$orig($instance) - if $self->has_value($instance); + # we only want to do this on the final recursive call + return $class->$orig(@_) + if $options->{metaclass}; - my $val = $instance->get_service($self->name)->get; + my ($new_class, @traits) = $class->$orig(@_); - if ($self->has_type_constraint) { - $val = $self->type_constraint->coerce($val) - if $self->should_coerce; + return wantarray ? ($new_class, @traits) : $new_class + if does_role($new_class, 'Bread::Board::Declare::Meta::Role::Attribute::Service'); - $self->verify_against_type_constraint($val, instance => $instance); - } + my $parent = @traits + ? (find_meta($new_class)->superclasses)[0] + : $new_class; + push @{ $options->{traits} }, 'Bread::Board::Declare::Meta::Role::Attribute::Service'; - if ($self->should_auto_deref) { - if (ref($val) eq 'ARRAY') { - return wantarray ? @$val : $val; - } - elsif (ref($val) eq 'HASH') { - return wantarray ? %$val : $val; - } - else { - die "Can't auto_deref $val."; - } - } - else { - return $val; - } + return $parent->interpolate_class($options); }; -if (Moose->VERSION > 1.9900) { - around _inline_instance_get => sub { - my $orig = shift; - my $self = shift; - my ($instance) = @_; - return 'do {' . "\n" - . 'my $val;' . "\n" - . 'if (' . $self->_inline_instance_has($instance) . ') {' . "\n" - . '$val = ' . $self->$orig($instance) . ';' . "\n" - . '}' . "\n" - . 'else {' . "\n" - . '$val = ' . $instance . '->get_service(\'' . $self->name . '\')->get;' . "\n" - . join("\n", $self->_inline_check_constraint( - '$val', - '$type_constraint', - (Moose->VERSION >= 2.0100 - ? '$type_message' - : '$type_constraint_obj'), - )) . "\n" - . '}' . "\n" - . '$val' . "\n" - . '}'; - }; -} -else { - around accessor_metaclass => sub { - my $orig = shift; - my $self = shift; - - return Moose::Meta::Class->create_anon_class( - superclasses => [ $self->$orig(@_) ], - roles => [ 'Bread::Board::Declare::Meta::Role::Accessor' ], - cache => 1 - )->name; - }; -} - no Moose::Role; 1; diff --git a/lib/Bread/Board/Declare/Meta/Role/Attribute/Service.pm b/lib/Bread/Board/Declare/Meta/Role/Attribute/Service.pm new file mode 100644 index 0000000..156443a --- /dev/null +++ b/lib/Bread/Board/Declare/Meta/Role/Attribute/Service.pm @@ -0,0 +1,291 @@ +package Bread::Board::Declare::Meta::Role::Attribute::Service; +use Moose::Role; +Moose::Util::meta_attribute_alias('Service'); +# ABSTRACT: attribute metarole for Bread::Board::Declare + +use Bread::Board::Types; +use List::MoreUtils qw(any); + +use Bread::Board::Declare::BlockInjection; +use Bread::Board::Declare::ConstructorInjection; +use Bread::Board::Declare::Literal; + +=head1 DESCRIPTION + +This role adds functionality to the attribute metaclass for +L objects. + +=cut + +=attr service + +Whether or not to create a service for this attribute. Defaults to true. + +=cut + +has service => ( + is => 'ro', + isa => 'Bool', + default => 1, +); + +=attr block + +The block to use when creating a L service. + +=cut + +has block => ( + is => 'ro', + isa => 'CodeRef', + predicate => 'has_block', +); + +=attr literal_value + +The value to use when creating a L service. Note that +the parameter that should be passed to C is C. + +=cut + +# has_value is already a method +has literal_value => ( + is => 'ro', + isa => 'Value', + init_arg => 'value', + predicate => 'has_literal_value', +); + +=attr lifecycle + +The lifecycle to use when creating the service. See L +and L. + +=cut + +has lifecycle => ( + is => 'ro', + isa => 'Str', + predicate => 'has_lifecycle', +); + +=attr dependencies + +The dependency specification to use when creating the service. See +L. + +=cut + +has dependencies => ( + is => 'ro', + isa => 'Bread::Board::Service::Dependencies', + coerce => 1, + predicate => 'has_dependencies', +); + +=attr parameters + +The parameter specification to use when creating the service. See L. + +=cut + +has parameters => ( + is => 'ro', + isa => 'Bread::Board::Service::Parameters', + coerce => 1, + predicate => 'has_parameters', +); + +=attr infer + +If true, the dependency list will be inferred as much as possible from the +attributes in the class. See L for +more information. Note that this is only valid for constructor injection +services. + +=cut + +has infer => ( + is => 'ro', + isa => 'Bool', +); + +=attr constructor_name + +The constructor name to use when creating L +services. Defaults to C. + +=cut + +has constructor_name => ( + is => 'ro', + isa => 'Str', + predicate => 'has_constructor_name', +); + +=attr associated_service + +The service object that is associated with this attribute. + +=cut + +has associated_service => ( + is => 'rw', + does => 'Bread::Board::Service', + predicate => 'has_associated_service', +); + +after attach_to_class => sub { + my $self = shift; + + return unless $self->service; + + my %params = ( + associated_attribute => $self, + name => $self->name, + ($self->has_lifecycle + ? (lifecycle => $self->lifecycle) + : ()), + ($self->has_dependencies + ? (dependencies => $self->dependencies) + : ()), + ($self->has_parameters + ? (parameters => $self->parameters) + : ()), + ($self->has_constructor_name + ? (constructor_name => $self->constructor_name) + : ()), + ); + + my $tc = $self->has_type_constraint ? $self->type_constraint : undef; + + my $service; + if ($self->has_block) { + if ($tc && $tc->isa('Moose::Meta::TypeConstraint::Class')) { + %params = (%params, class => $tc->class); + Class::MOP::load_class($tc->class); + } + $service = Bread::Board::Declare::BlockInjection->new( + %params, + block => $self->block, + ); + } + elsif ($self->has_literal_value) { + $service = Bread::Board::Declare::Literal->new( + %params, + value => $self->literal_value, + ); + } + elsif ($tc && $tc->isa('Moose::Meta::TypeConstraint::Class')) { + Class::MOP::load_class($tc->class); + $service = Bread::Board::Declare::ConstructorInjection->new( + %params, + class => $tc->class, + ); + } + else { + $service = Bread::Board::Declare::BlockInjection->new( + %params, + block => sub { + die "Attribute " . $self->name . " did not specify a service." + . " It must be given a value through the constructor or" + . " writer method before it can be resolved." + }, + ); + } + + $self->associated_service($service) if $service; +}; + +after _process_options => sub { + my $class = shift; + my ($name, $opts) = @_; + + return unless exists $opts->{default} + || exists $opts->{builder}; + return unless exists $opts->{class} + || exists $opts->{block} + || exists $opts->{value}; + + # XXX: uggggh + return if any { $_ eq 'Moose::Meta::Attribute::Native::Trait::String' + || $_ eq 'Moose::Meta::Attribute::Native::Trait::Counter' } + @{ $opts->{traits} }; + + my $exists = exists($opts->{default}) ? 'default' : 'builder'; + die "$exists is not valid when Bread::Board service options are set"; +}; + +around get_value => sub { + my $orig = shift; + my $self = shift; + my ($instance) = @_; + + return $self->$orig($instance) + if $self->has_value($instance); + + my $val = $instance->get_service($self->name)->get; + + if ($self->has_type_constraint) { + $val = $self->type_constraint->coerce($val) + if $self->should_coerce; + + $self->verify_against_type_constraint($val, instance => $instance); + } + + if ($self->should_auto_deref) { + if (ref($val) eq 'ARRAY') { + return wantarray ? @$val : $val; + } + elsif (ref($val) eq 'HASH') { + return wantarray ? %$val : $val; + } + else { + die "Can't auto_deref $val."; + } + } + else { + return $val; + } +}; + +if (Moose->VERSION > 1.9900) { + around _inline_instance_get => sub { + my $orig = shift; + my $self = shift; + my ($instance) = @_; + return 'do {' . "\n" + . 'my $val;' . "\n" + . 'if (' . $self->_inline_instance_has($instance) . ') {' . "\n" + . '$val = ' . $self->$orig($instance) . ';' . "\n" + . '}' . "\n" + . 'else {' . "\n" + . '$val = ' . $instance . '->get_service(\'' . $self->name . '\')->get;' . "\n" + . join("\n", $self->_inline_check_constraint( + '$val', + '$type_constraint', + (Moose->VERSION >= 2.0100 + ? '$type_message' + : '$type_constraint_obj'), + )) . "\n" + . '}' . "\n" + . '$val' . "\n" + . '}'; + }; +} +else { + around accessor_metaclass => sub { + my $orig = shift; + my $self = shift; + + return Moose::Meta::Class->create_anon_class( + superclasses => [ $self->$orig(@_) ], + roles => [ 'Bread::Board::Declare::Meta::Role::Accessor' ], + cache => 1 + )->name; + }; +} + +no Moose::Role; + +1; -- cgit v1.2.3