X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FAttribute%2FNative%2FTrait.pm;h=9250f307e1403cfee7aa499aa0d7e1e98c0cccdd;hb=refs%2Ftags%2F1.25;hp=bd8f2f64c30091a9bd7eef6d33d8a60f12879814;hpb=113d3174264db82cb788bc846f617584072cba39;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Attribute/Native/Trait.pm b/lib/Moose/Meta/Attribute/Native/Trait.pm index bd8f2f6..9250f30 100644 --- a/lib/Moose/Meta/Attribute/Native/Trait.pm +++ b/lib/Moose/Meta/Attribute/Native/Trait.pm @@ -1,56 +1,87 @@ package Moose::Meta::Attribute::Native::Trait; use Moose::Role; + +use List::MoreUtils qw( any uniq ); use Moose::Util::TypeConstraints; +use Moose::Deprecated; -our $VERSION = '0.91'; +our $VERSION = '1.25'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; requires '_helper_type'; -# these next two are the possible methods you can use in the 'handles' -# map. - -# provide a Class or Role which we can collect the method providers -# from - -# or you can provide a HASH ref of anon subs yourself. This will also -# collect and store the methods from a method_provider as well -has 'method_constructors' => ( - is => 'ro', - isa => 'HashRef', - lazy => 1, - default => sub { - my $self = shift; - return +{} unless $self->has_method_provider; - # or grab them from the role/class - my $method_provider = $self->method_provider->meta; - return +{ - map { - $_ => $method_provider->get_method($_) - } $method_provider->get_method_list - }; - }, +has _used_default_is => ( + is => 'rw', + isa => 'Bool', + default => 0, ); -has '+default' => ( required => 1 ); -has '+type_constraint' => ( required => 1 ); - -# methods called prior to instantiation - before '_process_options' => sub { my ( $self, $name, $options ) = @_; $self->_check_helper_type( $options, $name ); - $options->{is} = $self->_default_is - if ! exists $options->{is} && $self->can('_default_is'); + if ( !( any { exists $options->{$_} } qw( is reader writer accessor ) ) + && $self->can('_default_is') ) { - $options->{default} = $self->_default_default - if ! exists $options->{default} && $self->can('_default_default'); + $options->{is} = $self->_default_is; + + $options->{_used_default_is} = 1; + } + + if ( + !( + $options->{required} + || any { exists $options->{$_} } qw( default builder lazy_build ) + ) + && $self->can('_default_default') + ) { + + $options->{default} = $self->_default_default; + + Moose::Deprecated::deprecated( + feature => 'default default for Native Trait', + message => + 'Allowing a native trait to automatically supply a default is deprecated.' + . ' You can avoid this warning by supplying a default, builder, or making the attribute required' + ); + } }; +after 'install_accessors' => sub { + my $self = shift; + + return unless $self->_used_default_is; + + my @methods + = $self->_default_is eq 'rw' + ? qw( reader writer accessor ) + : 'reader'; + + my $name = $self->name; + my $class = $self->associated_class->name; + + for my $meth ( uniq grep {defined} map { $self->$_ } @methods ) { + + my $message + = "The $meth method in the $class class was automatically created" + . " by the native delegation trait for the $name attribute." + . q{ This "default is" feature is deprecated.} + . q{ Explicitly set "is" or define accessor names to avoid this}; + + $self->associated_class->add_before_method_modifier( + $meth => sub { + Moose::Deprecated::deprecated( + feature => 'default is for Native Trait', + message =>$message, + ); + } + ); + } + }; + sub _check_helper_type { my ( $self, $options, $name ) = @_; @@ -67,8 +98,26 @@ sub _check_helper_type { "The type constraint for $name must be a subtype of $type but it's a $isa"; } +before 'install_accessors' => sub { (shift)->_check_handles_values }; + +sub _check_handles_values { + my $self = shift; + + my %handles = $self->_canonicalize_handles; + + for my $original_method ( values %handles ) { + my $name = $original_method->[0]; + + my $accessor_class = $self->_native_accessor_class_for($name); + + ( $accessor_class && $accessor_class->can('new') ) + || confess + "$name is an unsupported method type - $accessor_class"; + } +} + around '_canonicalize_handles' => sub { - my $next = shift; + shift; my $self = shift; my $handles = $self->handles; @@ -76,7 +125,7 @@ around '_canonicalize_handles' => sub { unless ( 'HASH' eq ref $handles ) { $self->throw_error( - "The 'handles' option must be a HASH reference, not $handles" ); + "The 'handles' option must be a HASH reference, not $handles"); } return map { @@ -86,48 +135,64 @@ around '_canonicalize_handles' => sub { } keys %$handles; }; -# methods called after instantiation +around '_make_delegation_method' => sub { + my $next = shift; + my ( $self, $handle_name, $method_to_call ) = @_; -before 'install_accessors' => sub { (shift)->_check_handles_values }; + my ( $name, @curried_args ) = @$method_to_call; -sub _check_handles_values { - my $self = shift; + my $accessor_class = $self->_native_accessor_class_for($name); - my $method_constructors = $self->method_constructors; + die "Cannot find an accessor class for $name" + unless $accessor_class && $accessor_class->can('new'); - my %handles = $self->_canonicalize_handles; - - for my $original_method ( values %handles ) { - my $name = $original_method->[0]; - ( exists $method_constructors->{$name} ) - || confess "$name is an unsupported method type"; - } + return $accessor_class->new( + name => $handle_name, + package_name => $self->associated_class->name, + delegate_to_method => $name, + attribute => $self, + is_inline => 1, + curried_arguments => \@curried_args, + root_types => [ $self->_root_types ], + ); +}; +sub _root_types { + return $_[0]->_helper_type; } -around '_make_delegation_method' => sub { - my $next = shift; - my ( $self, $handle_name, $method_to_call ) = @_; +sub _native_accessor_class_for { + my ( $self, $suffix ) = @_; - my ( $name, @curried_args ) = @$method_to_call; + my $role + = 'Moose::Meta::Method::Accessor::Native::' + . $self->_native_type . '::' + . $suffix; - my $method_constructors = $self->method_constructors; + return Moose::Meta::Class->create_anon_class( + superclasses => + [ $self->accessor_metaclass, $self->delegation_metaclass ], + roles => [$role], + cache => 1, + )->name; +} - my $code = $method_constructors->{$name}->( - $self, - $self->get_read_method_ref, - $self->get_write_method_ref, - ); +sub _build_native_type { + my $self = shift; - return $next->( - $self, - $handle_name, - sub { - my $instance = shift; - return $code->( $instance, @curried_args, @_ ); - }, - ); -}; + for my $role_name ( map { $_->name } $self->meta->calculate_all_roles ) { + return $1 if $role_name =~ /::Native::Trait::(\w+)$/; + } + + die "Cannot calculate native type for " . ref $self; +} + +has '_native_type' => ( + is => 'ro', + isa => 'Str', + lazy => 1, + builder => '_build_native_type', +); no Moose::Role; no Moose::Util::TypeConstraints; @@ -138,13 +203,16 @@ __END__ =head1 NAME -Moose::Meta::Attribute::Native::Trait - Base role for helpers +Moose::Meta::Attribute::Native::Trait - Shared role for native delegation traits =head1 BUGS -All complex software has bugs lurking in it, and this module is no -exception. If you find a bug please either email me, or add the bug -to cpan-RT. +See L for details on reporting bugs. + +=head1 SEE ALSO + +Documentation for Moose native traits can be found in +L. =head1 AUTHORS @@ -156,7 +224,7 @@ Jesse Luehrs =head1 COPYRIGHT AND LICENSE -Copyright 2007-2009 by Infinity Interactive, Inc. +Copyright 2007-2010 by Infinity Interactive, Inc. L