X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FAttribute%2FNative%2FTrait.pm;h=a682e531eef57ff7331fb67be5605723f8b347dc;hb=d59d80d1e722dd9ec9bfb86e9b0a73d891b0a7c9;hp=76db9622e8f0dfd14a33e32ce3e652042cf8673c;hpb=f785aad8b8e799322985d8acce2bcb88fadc24a0;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Attribute/Native/Trait.pm b/lib/Moose/Meta/Attribute/Native/Trait.pm index 76db962..a682e53 100644 --- a/lib/Moose/Meta/Attribute/Native/Trait.pm +++ b/lib/Moose/Meta/Attribute/Native/Trait.pm @@ -1,53 +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.93'; +our $VERSION = '1.9900'; $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, ); -# 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->{is} = $self->_default_is; + + $options->{_used_default_is} = 1; + } - $options->{default} = $self->_default_default - if ! exists $options->{default} && $self->can('_default_default'); + 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 ) = @_; @@ -64,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; @@ -73,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 { @@ -83,48 +135,65 @@ around '_canonicalize_handles' => sub { } keys %$handles; }; -# methods called after instantiation - -before 'install_accessors' => sub { (shift)->_check_handles_values }; +around '_make_delegation_method' => sub { + my $next = shift; + my ( $self, $handle_name, $method_to_call ) = @_; -sub _check_handles_values { - my $self = shift; + my ( $name, @curried_args ) = @$method_to_call; - my $method_constructors = $self->method_constructors; + my $accessor_class = $self->_native_accessor_class_for($name); - my %handles = $self->_canonicalize_handles; + die "Cannot find an accessor class for $name" + unless $accessor_class && $accessor_class->can('new'); - 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 $role + = 'Moose::Meta::Method::Accessor::Native::' + . $self->_native_type . '::' + . $suffix; + + Class::MOP::load_class($role); + return Moose::Meta::Class->create_anon_class( + superclasses => + [ $self->accessor_metaclass, $self->delegation_metaclass ], + roles => [$role], + cache => 1, + )->name; +} - my ( $name, @curried_args ) = @$method_to_call; +sub _build_native_type { + my $self = shift; - my $method_constructors = $self->method_constructors; + for my $role_name ( map { $_->name } $self->meta->calculate_all_roles ) { + return $1 if $role_name =~ /::Native::Trait::(\w+)$/; + } - my $code = $method_constructors->{$name}->( - $self, - $self->get_read_method_ref, - $self->get_write_method_ref, - ); + die "Cannot calculate native type for " . ref $self; +} - return $next->( - $self, - $handle_name, - sub { - my $instance = shift; - return $code->( $instance, @curried_args, @_ ); - }, - ); -}; +has '_native_type' => ( + is => 'ro', + isa => 'Str', + lazy => 1, + builder => '_build_native_type', +); no Moose::Role; no Moose::Util::TypeConstraints; @@ -135,17 +204,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 starts at L +Documentation for Moose native traits can be found in +L. =head1 AUTHORS @@ -157,7 +225,7 @@ Jesse Luehrs =head1 COPYRIGHT AND LICENSE -Copyright 2007-2009 by Infinity Interactive, Inc. +Copyright 2007-2010 by Infinity Interactive, Inc. L