$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 {
};
}
-sub elements : method {
- my ( $attr, $reader, $writer ) = @_;
- return sub {
- my ($instance) = @_;
- @{ $reader->($instance) };
- };
-}
-
sub join : method {
my ( $attr, $reader, $writer ) = @_;
return sub {
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 ) = @_;
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 {
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;
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' => (
sub _helper_type { 'ArrayRef' }
+sub _native_type { 'Array' }
+
no Moose::Role;
1;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
'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' =>
'... 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' );
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' ],
projects / gitmo/Moose.git / commitdiff