From: Dave Rolsky Date: Wed, 15 Sep 2010 01:34:18 +0000 (-0500) Subject: Work in progress on inlining native traits methods. X-Git-Tag: 1.15~154 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f7fd22b6d12dedd3c0666e30c05b2e02b3e8acb3;hp=d4dc38edf420ab01de3f0be754d61aeb0e54bb43;p=gitmo%2FMoose.git Work in progress on inlining native traits methods. So far, so good, but we need to have much better tests, and tests need some serious cleanup too. --- diff --git a/lib/Moose/Meta/Attribute/Native/MethodProvider/Array.pm b/lib/Moose/Meta/Attribute/Native/MethodProvider/Array.pm index b4a4971..97bb97b 100644 --- a/lib/Moose/Meta/Attribute/Native/MethodProvider/Array.pm +++ b/lib/Moose/Meta/Attribute/Native/MethodProvider/Array.pm @@ -8,36 +8,6 @@ our $VERSION = '1.14'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; -sub count : method { - my ( $attr, $reader, $writer ) = @_; - return sub { - scalar @{ $reader->( $_[0] ) }; - }; -} - -sub is_empty : method { - my ( $attr, $reader, $writer ) = @_; - return sub { - scalar @{ $reader->( $_[0] ) } ? 0 : 1; - }; -} - -sub first : method { - my ( $attr, $reader, $writer ) = @_; - return sub { - my ( $instance, $predicate ) = @_; - List::Util::first { $predicate->() } @{ $reader->($instance) }; - }; -} - -sub map : method { - my ( $attr, $reader, $writer ) = @_; - return sub { - my ( $instance, $f ) = @_; - CORE::map { $f->() } @{ $reader->($instance) }; - }; -} - sub reduce : method { my ( $attr, $reader, $writer ) = @_; return sub { @@ -94,14 +64,6 @@ sub uniq : method { }; } -sub elements : method { - my ( $attr, $reader, $writer ) = @_; - return sub { - my ($instance) = @_; - @{ $reader->($instance) }; - }; -} - sub join : method { my ( $attr, $reader, $writer ) = @_; return sub { diff --git a/lib/Moose/Meta/Attribute/Native/Trait.pm b/lib/Moose/Meta/Attribute/Native/Trait.pm index 02b0400..8723047 100644 --- a/lib/Moose/Meta/Attribute/Native/Trait.pm +++ b/lib/Moose/Meta/Attribute/Native/Trait.pm @@ -9,29 +9,6 @@ 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 { $_->name => $_ } - $method_provider->_get_local_methods }; - }, -); - before '_process_options' => sub { my ( $self, $name, $options ) = @_; @@ -71,10 +48,13 @@ sub _check_handles_values { for my $original_method ( values %handles ) { my $name = $original_method->[0]; - ( exists $method_constructors->{$name} ) + + my $accessor_class + = $self->_native_accessor_class_root . '::' . $name; + + ( $accessor_class->can('new') || exists $method_constructors->{$name} ) || confess "$name is an unsupported method type"; } - } around '_canonicalize_handles' => sub { @@ -102,24 +82,58 @@ 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_root . '::' . $name; - 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, @_ ); - }, - ); + if ( $accessor_class->can('new') ) { + return $accessor_class->new( + name => $handle_name, + package_name => $self->associated_class->name, + attribute => $self, + curried_arguments => \@curried_args, + ); + } + 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, @_ ); + } + ); + } }; +sub _native_accessor_class_root { + my $self = shift; + + return 'Moose::Meta::Method::Accessor::Native::' . $self->_native_type; +} + +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 }; + }, +); + no Moose::Role; no Moose::Util::TypeConstraints; diff --git a/lib/Moose/Meta/Attribute/Native/Trait/Array.pm b/lib/Moose/Meta/Attribute/Native/Trait/Array.pm index dd6cef6..79a5e13 100644 --- a/lib/Moose/Meta/Attribute/Native/Trait/Array.pm +++ b/lib/Moose/Meta/Attribute/Native/Trait/Array.pm @@ -8,6 +8,13 @@ our $AUTHORITY = 'cpan:STEVAN'; use Moose::Meta::Attribute::Native::MethodProvider::Array; +use Moose::Meta::Method::Accessor::Native::Array::count; +use Moose::Meta::Method::Accessor::Native::Array::elements; +use Moose::Meta::Method::Accessor::Native::Array::first; +use Moose::Meta::Method::Accessor::Native::Array::is_empty; +use Moose::Meta::Method::Accessor::Native::Array::map; +use Moose::Meta::Method::Accessor::Native::Array::push; + with 'Moose::Meta::Attribute::Native::Trait'; has 'method_provider' => ( @@ -19,6 +26,8 @@ has 'method_provider' => ( sub _helper_type { 'ArrayRef' } +sub _native_type { 'Array' } + no Moose::Role; 1; diff --git a/lib/Moose/Meta/Method/Accessor/Native.pm b/lib/Moose/Meta/Method/Accessor/Native.pm new file mode 100644 index 0000000..77fc6b9 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native.pm @@ -0,0 +1,67 @@ +package Moose::Meta::Method::Accessor::Native; + +use strict; +use warnings; + +use Carp qw( confess ); +use Scalar::Util qw( blessed weaken ); + +our $VERSION = '1.13'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +use base 'Moose::Meta::Method::Accessor', 'Moose::Meta::Method::Delegation'; + +sub new { + my $class = shift; + my %options = @_; + + die "Cannot instantiate a $class object directly" + if $class eq __PACKAGE__; + + ( exists $options{attribute} ) + || confess "You must supply an attribute to construct with"; + + ( blessed( $options{attribute} ) + && $options{attribute}->isa('Class::MOP::Attribute') ) + || confess + "You must supply an attribute which is a 'Class::MOP::Attribute' instance"; + + ( $options{package_name} && $options{name} ) + || confess "You must supply the package_name and name parameters"; + + exists $options{curried_arguments} + || ( $options{curried_arguments} = [] ); + + ( $options{curried_arguments} + && ( 'ARRAY' eq ref $options{curried_arguments} ) ) + || confess + 'You must supply a curried_arguments which is an ARRAY reference'; + + $options{delegate_to_method} = lc( ( split /::/, $class)[-1] ); + + my $self = $class->_new( \%options ); + + weaken( $self->{'attribute'} ); + + $self->_initialize_body; + + return $self; +} + +sub _new { + my $class = shift; + my $options = @_ == 1 ? $_[0] : {@_}; + + return bless $options, $class; +} + +sub _initialize_body { + my $self = shift; + + $self->{'body'} = $self->_eval_code( $self->_generate_method ); + + return; +} + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array.pm b/lib/Moose/Meta/Method/Accessor/Native/Array.pm new file mode 100644 index 0000000..13ef392 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array.pm @@ -0,0 +1,51 @@ +package Moose::Meta::Method::Accessor::Native::Array; + +use strict; +use warnings; + +use B; +use Scalar::Util qw( looks_like_number ); + +our $VERSION = '1.13'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +use base 'Moose::Meta::Method::Accessor::Native'; + +sub _value_needs_copy { + my $self = shift; + + return @{ $self->curried_arguments }; +} + +sub _inline_copy_value { + my $self = shift; + + return q{} unless $self->_value_needs_copy; + + my $curry = join ', ', + map { looks_like_number($_) ? $_ : B::perlstring($_) } + @{ $self->curried_arguments }; + + return "my \@val = ( $curry, \@_ );"; +} + +sub _inline_check_constraint { + my $self = shift; + + return q{} unless $self->_constraint_must_be_checked; + + return $self->SUPER::_inline_check_constraint(@_); +} + +sub _constraint_must_be_checked { + my $self = shift; + + my $attr = $self->associated_attribute; + + return $attr->has_type_constraint + && ( $attr->type_constraint->name ne 'ArrayRef' + || ( $attr->should_coerce && $attr->type_constraint->has_coercion ) ); +} + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/Reader.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/Reader.pm new file mode 100644 index 0000000..04d8799 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/Reader.pm @@ -0,0 +1,42 @@ +package Moose::Meta::Method::Accessor::Native::Array::Reader; + +use strict; +use warnings; + +our $VERSION = '1.13'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +use base 'Moose::Meta::Method::Accessor::Native::Array'; + +sub _generate_method { + my $self = shift; + + my $inv = '$self'; + + my $code = 'sub {'; + $code .= "\n" . $self->_inline_pre_body(@_); + + $code .= "\n" . 'my $self = shift;'; + $code .= "\n" . $self->_inline_process_arguments; + + $code + .= "\n" + . $self->_inline_throw_error( + q{"Cannot assign a value to a read-only accessor"}, 'data => \@_' ) + . ' if @_ > 1;'; + + $code .= "\n" . $self->_inline_check_lazy($inv); + $code .= "\n" . $self->_inline_post_body(@_); + + my $slot_access = $self->_inline_get($inv); + + $code .= "\n" . 'return ' . $self->_return_value($slot_access) . ';'; + $code .= "\n}"; + + return $code; +} + +sub _inline_process_arguments { q{} } + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/Writer.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/Writer.pm new file mode 100644 index 0000000..4c53ab1 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/Writer.pm @@ -0,0 +1,12 @@ +package Moose::Meta::Method::Accessor::Native::Array::Writer; + +use strict; +use warnings; + +our $VERSION = '1.13'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +use base 'Moose::Meta::Method::Accessor::Native::Array'; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/count.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/count.pm new file mode 100644 index 0000000..148a1b5 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/count.pm @@ -0,0 +1,19 @@ +package Moose::Meta::Method::Accessor::Native::Array::count; + +use strict; +use warnings; + +our $VERSION = '1.13'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +use base 'Moose::Meta::Method::Accessor::Native::Array::Reader'; + +sub _return_value { + my $self = shift; + my $slot_access = shift; + + return "scalar \@{ $slot_access }"; +} + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/elements.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/elements.pm new file mode 100644 index 0000000..2324ac9 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/elements.pm @@ -0,0 +1,19 @@ +package Moose::Meta::Method::Accessor::Native::Array::elements; + +use strict; +use warnings; + +our $VERSION = '1.13'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +use base 'Moose::Meta::Method::Accessor::Native::Array::Reader'; + +sub _return_value { + my $self = shift; + my $slot_access = shift; + + return "\@{ $slot_access }"; +} + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/first.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/first.pm new file mode 100644 index 0000000..007a9f0 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/first.pm @@ -0,0 +1,19 @@ +package Moose::Meta::Method::Accessor::Native::Array::first; + +use strict; +use warnings; + +our $VERSION = '1.13'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +use base 'Moose::Meta::Method::Accessor::Native::Array::Reader'; + +sub _return_value { + my $self = shift; + my $slot_access = shift; + + return "${slot_access}->[0]"; +} + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/is_empty.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/is_empty.pm new file mode 100644 index 0000000..faa35ce --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/is_empty.pm @@ -0,0 +1,19 @@ +package Moose::Meta::Method::Accessor::Native::Array::is_empty; + +use strict; +use warnings; + +our $VERSION = '1.13'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +use base 'Moose::Meta::Method::Accessor::Native::Array::Reader'; + +sub _return_value { + my $self = shift; + my $slot_access = shift; + + return "\@{ $slot_access } ? 0 : 1"; +} + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/map.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/map.pm new file mode 100644 index 0000000..d7a46b3 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/map.pm @@ -0,0 +1,23 @@ +package Moose::Meta::Method::Accessor::Native::Array::map; + +use strict; +use warnings; + +our $VERSION = '1.13'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +use base 'Moose::Meta::Method::Accessor::Native::Array::Reader'; + +sub _inline_process_arguments { + return 'my $func = shift;'; +} + +sub _return_value { + my $self = shift; + my $slot_access = shift; + + return "map { \$func->() } \@{ $slot_access }"; +} + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/push.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/push.pm new file mode 100644 index 0000000..bf7b3aa --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/push.pm @@ -0,0 +1,64 @@ +package Moose::Meta::Method::Accessor::Native::Array::push; + +use strict; +use warnings; + +our $VERSION = '1.13'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +use base 'Moose::Meta::Method::Accessor::Native::Array::Writer'; + +sub _generate_method { + my $self = shift; + + my $inv = '$self'; + + my $slot_access = $self->_inline_get($inv); + + my $value_name + = $self->_value_needs_copy + ? '@val' + : '@_'; + + my $code = 'sub {'; + $code .= "\n" . $self->_inline_pre_body(@_); + + $code .= "\n" . 'my $self = shift;'; + + $code .= "\n" . $self->_inline_check_lazy($inv); + + $code .= "\n" . $self->_inline_copy_value; + + $code + .= "\n" + . $self->_inline_throw_error( + q{"Cannot call push without any arguments"}) + . " unless $value_name;"; + + my $potential_new_val; + if ( $self->_constraint_must_be_checked ) { + $code .= "\n" . "my \@new_val = ( \@{ $slot_access }, $value_name );"; + $potential_new_val = '\\@new_val'; + } + else { + $potential_new_val = "[ \@{ $slot_access }, $value_name ];"; + } + + $code .= "\n" . $self->_inline_check_coercion($potential_new_val); + $code .= "\n" . $self->_inline_check_constraint($potential_new_val); + + $code .= "\n" + . $self->_inline_get_old_value_for_trigger( $inv, $value_name ); + + $code .= "\n" . $self->_inline_store( $inv, $potential_new_val ); + + $code .= "\n" . $self->_inline_post_body(@_); + $code .= "\n" . $self->_inline_trigger( $inv, $value_name, '@old' ); + + $code .= "\n}"; + + return $code; +} + +1; diff --git a/t/070_native_traits/202_trait_array.t b/t/070_native_traits/202_trait_array.t index fc8500f..ca071dc 100644 --- a/t/070_native_traits/202_trait_array.t +++ b/t/070_native_traits/202_trait_array.t @@ -32,6 +32,9 @@ my $sort; 'splice_options' => 'splice', 'sort_options_in_place' => 'sort_in_place', 'option_accessor' => 'accessor', + 'all_options' => 'elements', + 'first_option' => 'first', + 'mapped_options' => 'map', 'add_options_with_speed' => [ 'push' => 'funrolls', 'funbuns' ], 'prepend_prerequisites_along_with' => @@ -78,6 +81,10 @@ lives_ok { '... set the option okay'; is_deeply( $stuff->options, [ 1, 2, 3 ], '... got options now' ); +is_deeply( [ $stuff->all_options ], [ 1, 2, 3 ], '... got options now (with elements method)' ); +is( $stuff->first_option, 1, '... got first option' ); +is_deeply( [ $stuff->mapped_options( sub { $_ * 10 } ) ], [ 10, 20, 30 ], + '... got mapped options' ); ok( !$stuff->has_no_options, '... has options' ); is( $stuff->num_options, 3, '... got 3 options' ); @@ -246,20 +253,22 @@ my $options = $stuff->meta->get_attribute('options'); does_ok( $options, 'Moose::Meta::Attribute::Native::Trait::Array' ); is_deeply( - $options->handles, - { - 'add_options' => 'push', - 'remove_last_option' => 'pop', - 'remove_first_option' => 'shift', - 'insert_options' => 'unshift', - 'get_option_at' => 'get', - 'set_option_at' => 'set', - 'num_options' => 'count', - 'has_no_options' => 'is_empty', - 'clear_options' => 'clear', - 'splice_options' => 'splice', - 'sort_options_in_place' => 'sort_in_place', - 'option_accessor' => 'accessor', + $options->handles, { + 'add_options' => 'push', + 'remove_last_option' => 'pop', + 'remove_first_option' => 'shift', + 'insert_options' => 'unshift', + 'get_option_at' => 'get', + 'set_option_at' => 'set', + 'num_options' => 'count', + 'has_no_options' => 'is_empty', + 'clear_options' => 'clear', + 'splice_options' => 'splice', + 'sort_options_in_place' => 'sort_in_place', + 'option_accessor' => 'accessor', + 'all_options' => 'elements', + 'first_option' => 'first', + 'mapped_options' => 'map', 'add_options_with_speed' => [ 'push' => 'funrolls', 'funbuns' ], 'prepend_prerequisites_along_with' => [ 'unshift' => 'first', 'second' ],