X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FAttribute%2FNative%2FTrait.pm;h=b0065466f8ebd84ac927a2089896a2556178b60c;hb=6bd9df2b273b5784fadb33a1d61d4d108519adf8;hp=b6c6eb6072e4ebdf7c5ff6b54c77570a542bb305;hpb=01839bb8436ff7acbc49128728f5af2bd2f47135;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Attribute/Native/Trait.pm b/lib/Moose/Meta/Attribute/Native/Trait.pm index b6c6eb6..b006546 100644 --- a/lib/Moose/Meta/Attribute/Native/Trait.pm +++ b/lib/Moose/Meta/Attribute/Native/Trait.pm @@ -1,53 +1,84 @@ package Moose::Meta::Attribute::Native::Trait; use Moose::Role; -use Moose::Util::TypeConstraints; -our $VERSION = '1.09'; -$VERSION = eval $VERSION; -our $AUTHORITY = 'cpan:STEVAN'; +use Class::Load qw(load_class); +use List::MoreUtils qw( any uniq ); +use Moose::Util::TypeConstraints; +use Moose::Deprecated; 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 { - $_->name => $_ - } $method_provider->_get_local_methods - }; - }, +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 +95,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,33 +122,25 @@ 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 { - my $to = $handles->{$_}; - $to = [$to] unless ref $to; - $_ => $to - } keys %$handles; + return + map { $_ => $self->_canonicalize_handles_value( $handles->{$_} ) } + keys %$handles; }; -# methods called after instantiation - -before 'install_accessors' => sub { (shift)->_check_handles_values }; +sub _canonicalize_handles_value { + my $self = shift; + my $value = shift; -sub _check_handles_values { - my $self = shift; - - my $method_constructors = $self->method_constructors; - - 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"; + if ( ref $value && 'ARRAY' ne ref $value ) { + $self->throw_error( + "All values passed to handles must be strings or ARRAY references, not $value" + ); } + return ref $value ? $value : [$value]; } around '_make_delegation_method' => sub { @@ -108,58 +149,76 @@ around '_make_delegation_method' => sub { my ( $name, @curried_args ) = @$method_to_call; - my $method_constructors = $self->method_constructors; + my $accessor_class = $self->_native_accessor_class_for($name); - my $code = $method_constructors->{$name}->( - $self, - $self->get_read_method_ref, - $self->get_write_method_ref, - ); + die "Cannot find an accessor class for $name" + unless $accessor_class && $accessor_class->can('new'); - return $next->( - $self, - $handle_name, - sub { - my $instance = shift; - return $code->( $instance, @curried_args, @_ ); - }, + 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 ], ); }; -no Moose::Role; -no Moose::Util::TypeConstraints; - -1; - -__END__ - -=head1 NAME +sub _root_types { + return $_[0]->_helper_type; +} -Moose::Meta::Attribute::Native::Trait - Base role for helpers +sub _native_accessor_class_for { + my ( $self, $suffix ) = @_; + + my $role + = 'Moose::Meta::Method::Accessor::Native::' + . $self->_native_type . '::' + . $suffix; + + load_class($role); + return Moose::Meta::Class->create_anon_class( + superclasses => + [ $self->accessor_metaclass, $self->delegation_metaclass ], + roles => [$role], + cache => 1, + )->name; +} -=head1 BUGS +sub _build_native_type { + my $self = shift; -See L for details on reporting bugs. + for my $role_name ( map { $_->name } $self->meta->calculate_all_roles ) { + return $1 if $role_name =~ /::Native::Trait::(\w+)$/; + } -=head1 SEE ALSO + die "Cannot calculate native type for " . ref $self; +} -Documentation for Moose native traits starts at L +has '_native_type' => ( + is => 'ro', + isa => 'Str', + lazy => 1, + builder => '_build_native_type', +); -=head1 AUTHORS +no Moose::Role; +no Moose::Util::TypeConstraints; -Yuval Kogman +1; -Shawn M Moore +# ABSTRACT: Shared role for native delegation traits -Jesse Luehrs +__END__ -=head1 COPYRIGHT AND LICENSE +=head1 BUGS -Copyright 2007-2009 by Infinity Interactive, Inc. +See L for details on reporting bugs. -L +=head1 SEE ALSO -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. +Documentation for Moose native traits can be found in +L. =cut