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=2a77fca21f0d7d4209bcf6c3bef06e7cfacb2bfa;hpb=ffc2e25f14e354132f1c4b93702ed016779493c6;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Attribute/Native/Trait.pm b/lib/Moose/Meta/Attribute/Native/Trait.pm index 2a77fca..9250f30 100644 --- a/lib/Moose/Meta/Attribute/Native/Trait.pm +++ b/lib/Moose/Meta/Attribute/Native/Trait.pm @@ -1,26 +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 = '1.14'; +our $VERSION = '1.25'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; requires '_helper_type'; +has _used_default_is => ( + is => 'rw', + isa => 'Bool', + default => 0, +); + 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 ) = @_; @@ -42,8 +103,6 @@ before 'install_accessors' => sub { (shift)->_check_handles_values }; sub _check_handles_values { my $self = shift; - my $method_constructors = $self->method_constructors; - my %handles = $self->_canonicalize_handles; for my $original_method ( values %handles ) { @@ -51,10 +110,9 @@ sub _check_handles_values { my $accessor_class = $self->_native_accessor_class_for($name); - # XXX - bridge code - ( ( $accessor_class && $accessor_class->can('new') ) - || exists $method_constructors->{$name} ) - || confess "$name is an unsupported method type"; + ( $accessor_class && $accessor_class->can('new') ) + || confess + "$name is an unsupported method type - $accessor_class"; } } @@ -85,60 +143,55 @@ around '_make_delegation_method' => sub { my $accessor_class = $self->_native_accessor_class_for($name); - # XXX - bridge code - if ( $accessor_class && $accessor_class->can('new') ) { - return $accessor_class->new( - name => $handle_name, - package_name => $self->associated_class->name, - attribute => $self, - curried_arguments => \@curried_args, - ); - } - # XXX - bridge code - else { - my $method_constructors = $self->method_constructors; - - my $code = $method_constructors->{$name}->( - $self, - $self->get_read_method_ref, - $self->get_write_method_ref, - ); - - return $next->( - $self, - $handle_name, - sub { - my $instance = shift; - return $code->( $instance, @curried_args, @_ ); - } - ); - } + die "Cannot find an accessor class for $name" + unless $accessor_class && $accessor_class->can('new'); + + 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; +} + sub _native_accessor_class_for { my ( $self, $suffix ) = @_; - # XXX - bridge code - return unless $self->can('_native_type'); + my $role + = 'Moose::Meta::Method::Accessor::Native::' + . $self->_native_type . '::' + . $suffix; + + return Moose::Meta::Class->create_anon_class( + superclasses => + [ $self->accessor_metaclass, $self->delegation_metaclass ], + roles => [$role], + cache => 1, + )->name; +} + +sub _build_native_type { + my $self = shift; + + for my $role_name ( map { $_->name } $self->meta->calculate_all_roles ) { + return $1 if $role_name =~ /::Native::Trait::(\w+)$/; + } - return 'Moose::Meta::Method::Accessor::Native::' . $self->_native_type . '::' . $suffix; + die "Cannot calculate native type for " . ref $self; } -has 'method_constructors' => ( +has '_native_type' => ( is => 'ro', - isa => 'HashRef', + isa => 'Str', lazy => 1, - default => sub { - my $self = shift; - return +{} - unless $self->can('has_method_provider') - && $self->has_method_provider; - - # or grab them from the role/class - my $method_provider = $self->method_provider->meta; - return +{ map { $_->name => $_ } - $method_provider->_get_local_methods }; - }, + builder => '_build_native_type', ); no Moose::Role; @@ -150,7 +203,7 @@ __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 @@ -158,7 +211,8 @@ See L for details on reporting bugs. =head1 SEE ALSO -Documentation for Moose native traits starts at L +Documentation for Moose native traits can be found in +L. =head1 AUTHORS @@ -170,7 +224,7 @@ Jesse Luehrs =head1 COPYRIGHT AND LICENSE -Copyright 2007-2009 by Infinity Interactive, Inc. +Copyright 2007-2010 by Infinity Interactive, Inc. L