From: Dave Rolsky Date: Fri, 17 Sep 2010 20:39:36 +0000 (-0500) Subject: All native array methods are being inlined. X-Git-Tag: 1.15~149 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a7821be5fbdedff67afce753d73c580ae5ada592;p=gitmo%2FMoose.git All native array methods are being inlined. All native methods are tested --- diff --git a/lib/Moose/Meta/Attribute/Native/MethodProvider/Array.pm b/lib/Moose/Meta/Attribute/Native/MethodProvider/Array.pm deleted file mode 100644 index d6f3538..0000000 --- a/lib/Moose/Meta/Attribute/Native/MethodProvider/Array.pm +++ /dev/null @@ -1,263 +0,0 @@ -package Moose::Meta::Attribute::Native::MethodProvider::Array; -use Moose::Role; - -use List::Util; -use List::MoreUtils; - -our $VERSION = '1.14'; -$VERSION = eval $VERSION; -our $AUTHORITY = 'cpan:STEVAN'; - -sub pop : method { - my ( $attr, $reader, $writer ) = @_; - return sub { - CORE::pop @{ $reader->( $_[0] ) }; - }; -} - -sub unshift : method { - my ( $attr, $reader, $writer ) = @_; - if ( - $attr->has_type_constraint - && $attr->type_constraint->isa( - 'Moose::Meta::TypeConstraint::Parameterized') - ) - { - my $container_type_constraint = $attr->type_constraint->type_parameter; - return sub { - my $instance = CORE::shift; - $container_type_constraint->check($_) - || confess "Value " - . ( $_ || 'undef' ) - . " did not pass container type constraint '$container_type_constraint'" - foreach @_; - CORE::unshift @{ $reader->($instance) } => @_; - }; - } - else { - return sub { - my $instance = CORE::shift; - CORE::unshift @{ $reader->($instance) } => @_; - }; - } -} - -sub shift : method { - my ( $attr, $reader, $writer ) = @_; - return sub { - CORE::shift @{ $reader->( $_[0] ) }; - }; -} - -sub set : method { - my ( $attr, $reader, $writer ) = @_; - if ( - $attr->has_type_constraint - && $attr->type_constraint->isa( - 'Moose::Meta::TypeConstraint::Parameterized') - ) - { - my $container_type_constraint = $attr->type_constraint->type_parameter; - return sub { - ( $container_type_constraint->check( $_[2] ) ) - || confess "Value " - . ( $_[2] || 'undef' ) - . " did not pass container type constraint '$container_type_constraint'"; - $reader->( $_[0] )->[ $_[1] ] = $_[2]; - }; - } - else { - return sub { - $reader->( $_[0] )->[ $_[1] ] = $_[2]; - }; - } -} - -sub accessor : method { - my ( $attr, $reader, $writer ) = @_; - - if ( - $attr->has_type_constraint - && $attr->type_constraint->isa( - 'Moose::Meta::TypeConstraint::Parameterized') - ) - { - my $container_type_constraint = $attr->type_constraint->type_parameter; - return sub { - my $self = shift; - - if ( @_ == 1 ) { # reader - return $reader->($self)->[ $_[0] ]; - } - elsif ( @_ == 2 ) { # writer - ( $container_type_constraint->check( $_[1] ) ) - || confess "Value " - . ( $_[1] || 'undef' ) - . " did not pass container type constraint '$container_type_constraint'"; - $reader->($self)->[ $_[0] ] = $_[1]; - } - else { - confess "One or two arguments expected, not " . @_; - } - }; - } - else { - return sub { - my $self = shift; - - if ( @_ == 1 ) { # reader - return $reader->($self)->[ $_[0] ]; - } - elsif ( @_ == 2 ) { # writer - $reader->($self)->[ $_[0] ] = $_[1]; - } - else { - confess "One or two arguments expected, not " . @_; - } - }; - } -} - -sub clear : method { - my ( $attr, $reader, $writer ) = @_; - return sub { - @{ $reader->( $_[0] ) } = (); - }; -} - -sub delete : method { - my ( $attr, $reader, $writer ) = @_; - return sub { - CORE::splice @{ $reader->( $_[0] ) }, $_[1], 1; - } -} - -sub insert : method { - my ( $attr, $reader, $writer ) = @_; - if ( - $attr->has_type_constraint - && $attr->type_constraint->isa( - 'Moose::Meta::TypeConstraint::Parameterized') - ) - { - my $container_type_constraint = $attr->type_constraint->type_parameter; - return sub { - ( $container_type_constraint->check( $_[2] ) ) - || confess "Value " - . ( $_[2] || 'undef' ) - . " did not pass container type constraint '$container_type_constraint'"; - CORE::splice @{ $reader->( $_[0] ) }, $_[1], 0, $_[2]; - }; - } - else { - return sub { - CORE::splice @{ $reader->( $_[0] ) }, $_[1], 0, $_[2]; - }; - } -} - -sub splice : method { - my ( $attr, $reader, $writer ) = @_; - if ( - $attr->has_type_constraint - && $attr->type_constraint->isa( - 'Moose::Meta::TypeConstraint::Parameterized') - ) - { - my $container_type_constraint = $attr->type_constraint->type_parameter; - return sub { - my ( $self, $i, $j, @elems ) = @_; - ( $container_type_constraint->check($_) ) - || confess "Value " - . ( defined($_) ? $_ : 'undef' ) - . " did not pass container type constraint '$container_type_constraint'" - for @elems; - CORE::splice @{ $reader->($self) }, $i, $j, @elems; - }; - } - else { - return sub { - my ( $self, $i, $j, @elems ) = @_; - CORE::splice @{ $reader->($self) }, $i, $j, @elems; - }; - } -} - -sub sort_in_place : method { - my ( $attr, $reader, $writer ) = @_; - return sub { - my ( $instance, $predicate ) = @_; - - die "Argument must be a code reference" - if $predicate && ref $predicate ne 'CODE'; - - my @sorted; - if ($predicate) { - @sorted = - CORE::sort { $predicate->( $a, $b ) } @{ $reader->($instance) }; - } - else { - @sorted = CORE::sort @{ $reader->($instance) }; - } - - $writer->( $instance, \@sorted ); - }; -} - -sub natatime : method { - my ( $attr, $reader, $writer ) = @_; - return sub { - my ( $instance, $n, $f ) = @_; - my $it = List::MoreUtils::natatime($n, @{ $reader->($instance) }); - return $it unless $f; - - while (my @vals = $it->()) { - $f->(@vals); - } - - return; - }; -} - -1; - -__END__ - -=pod - -=head1 NAME - -Moose::Meta::Attribute::Native::MethodProvider::Array - role providing method generators for Array trait - -=head1 DESCRIPTION - -This is a role which provides the method generators for -L. Please check there for -documentation on what methods are provided. - -=head1 METHODS - -=over 4 - -=item B - -=back - -=head1 BUGS - -See L for details on reporting bugs. - -=head1 AUTHOR - -Stevan Little Estevan@iinteractive.comE - -=head1 COPYRIGHT AND LICENSE - -Copyright 2007-2009 by Infinity Interactive, Inc. - -L - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/lib/Moose/Meta/Attribute/Native/Trait.pm b/lib/Moose/Meta/Attribute/Native/Trait.pm index 8723047..c3b9212 100644 --- a/lib/Moose/Meta/Attribute/Native/Trait.pm +++ b/lib/Moose/Meta/Attribute/Native/Trait.pm @@ -125,7 +125,9 @@ has 'method_constructors' => ( lazy => 1, default => sub { my $self = shift; - return +{} unless $self->has_method_provider; + 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; diff --git a/lib/Moose/Meta/Attribute/Native/Trait/Array.pm b/lib/Moose/Meta/Attribute/Native/Trait/Array.pm index 0defb44..987f8d5 100644 --- a/lib/Moose/Meta/Attribute/Native/Trait/Array.pm +++ b/lib/Moose/Meta/Attribute/Native/Trait/Array.pm @@ -6,31 +6,33 @@ our $VERSION = '1.14'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; -use Moose::Meta::Attribute::Native::MethodProvider::Array; - +use Moose::Meta::Method::Accessor::Native::Array::accessor; +use Moose::Meta::Method::Accessor::Native::Array::clear; use Moose::Meta::Method::Accessor::Native::Array::count; +use Moose::Meta::Method::Accessor::Native::Array::delete; use Moose::Meta::Method::Accessor::Native::Array::elements; use Moose::Meta::Method::Accessor::Native::Array::first; use Moose::Meta::Method::Accessor::Native::Array::get; use Moose::Meta::Method::Accessor::Native::Array::grep; +use Moose::Meta::Method::Accessor::Native::Array::insert; use Moose::Meta::Method::Accessor::Native::Array::is_empty; use Moose::Meta::Method::Accessor::Native::Array::join; use Moose::Meta::Method::Accessor::Native::Array::map; +use Moose::Meta::Method::Accessor::Native::Array::natatime; +use Moose::Meta::Method::Accessor::Native::Array::pop; use Moose::Meta::Method::Accessor::Native::Array::push; use Moose::Meta::Method::Accessor::Native::Array::reduce; +use Moose::Meta::Method::Accessor::Native::Array::set; +use Moose::Meta::Method::Accessor::Native::Array::shift; use Moose::Meta::Method::Accessor::Native::Array::shuffle; +use Moose::Meta::Method::Accessor::Native::Array::splice; use Moose::Meta::Method::Accessor::Native::Array::sort; +use Moose::Meta::Method::Accessor::Native::Array::sort_in_place; use Moose::Meta::Method::Accessor::Native::Array::uniq; +use Moose::Meta::Method::Accessor::Native::Array::unshift; with 'Moose::Meta::Attribute::Native::Trait'; -has 'method_provider' => ( - is => 'ro', - isa => 'ClassName', - predicate => 'has_method_provider', - default => 'Moose::Meta::Attribute::Native::MethodProvider::Array' -); - sub _helper_type { 'ArrayRef' } sub _native_type { 'Array' } diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array.pm b/lib/Moose/Meta/Method/Accessor/Native/Array.pm index d30033b..6861a71 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/Array.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/Array.pm @@ -20,26 +20,52 @@ sub _inline_curried_arguments { return 'unshift @_, @curried;' } -sub _inline_check_constraint { +sub _inline_check_argument_count { my $self = shift; - return q{} unless $self->_constraint_must_be_checked; - - return $self->SUPER::_inline_check_constraint(@_); + my $code = q{}; + + if ( my $min = $self->_minimum_arguments ) { + my $err_msg = sprintf( + q{"Cannot call %s without at least %s argument%s"}, + $self->delegate_to_method, + $min, + ( $min == 1 ? q{} : 's' ) + ); + + $code + .= "\n" + . $self->_inline_throw_error($err_msg) + . " unless \@_ >= $min;"; + } + + if ( defined( my $max = $self->_maximum_arguments ) ) { + my $err_msg = sprintf( + q{"Cannot call %s with %s argument%s"}, + $self->delegate_to_method, + ( $max ? "more than $max" : 'any' ), + ( $max == 1 ? q{} : 's' ) + ); + + $code + .= "\n" + . $self->_inline_throw_error($err_msg) + . " if \@_ > $max;"; + } + + return $code; } -sub _constraint_must_be_checked { - my $self = shift; - - my $attr = $self->associated_attribute; +sub _minimum_arguments { 0 } +sub _maximum_arguments { undef } - return $attr->has_type_constraint - && ( $attr->type_constraint->name ne 'ArrayRef' - || ( $attr->should_coerce && $attr->type_constraint->has_coercion ) ); -} +sub _inline_check_arguments { q{} } -sub _inline_process_arguments { q{} } +sub _inline_check_var_is_valid_index { + my ( $self, $var ) = @_; -sub _inline_check_arguments { q{} } + return + qq{die 'Must provide a valid index number as an argument' unless defined $var && $var =~ /^-?\\d+\$/;}; +} 1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/Reader.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/Reader.pm index 39ce6a9..d46bea6 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/Array/Reader.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/Reader.pm @@ -19,24 +19,24 @@ sub _generate_method { $code .= "\n" . 'my $self = shift;'; $code .= "\n" . $self->_inline_curried_arguments; - $code .= "\n" . $self->_inline_process_arguments; + $code .= "\n" . $self->_inline_check_argument_count; $code .= "\n" . $self->_inline_check_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" . $self->_inline_return_value($slot_access); $code .= "\n}"; return $code; } +sub _inline_return_value { + my ( $self, $slot_access ) = @_; + + 'return ' . $self->_return_value($slot_access) . ';'; +} + 1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/Writer.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/Writer.pm index 4c53ab1..5e655d5 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/Array/Writer.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/Writer.pm @@ -9,4 +9,158 @@ our $AUTHORITY = 'cpan:STEVAN'; use base 'Moose::Meta::Method::Accessor::Native::Array'; +sub _generate_method { + my $self = shift; + + my $inv = '$self'; + + my $slot_access = $self->_inline_get($inv); + + 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_curried_arguments; + + $code .= "\n" . $self->_inline_check_argument_count; + + $code .= "\n" . $self->_inline_process_arguments; + + $code .= "\n" . $self->_inline_check_arguments; + + my $new_values = $self->_new_values($slot_access); + my $potential_value = $self->_potential_value($slot_access); + + $code .= "\n" + . $self->_inline_tc_code( + $new_values, + $potential_value + ); + + $code .= "\n" . $self->_inline_get_old_value_for_trigger($inv); + $code .= "\n" . $self->_capture_old_value($slot_access); + + $code .= "\n" . $self->_inline_store( $inv, '[' . $potential_value . ']' ); + + $code .= "\n" . $self->_inline_post_body(@_); + $code .= "\n" . $self->_inline_trigger( $inv, $slot_access, '@old' ); + + $code .= "\n" . $self->_return_value( $inv, '@old' ); + + $code .= "\n}"; + + return $code; +} + +sub _inline_process_arguments { q{} } + +sub _inline_check_arguments { q{} } + +sub _new_values { '@_' } + +sub _inline_tc_code { + my ( $self, $new_value, $potential_value ) = @_; + + return q{} unless $self->_constraint_must_be_checked; + + if ( $self->_check_new_members_only ) { + return q{} unless $self->_adds_members; + + return $self->_inline_check_member_constraint($new_value); + } + else { + return $self->_inline_check_coercion($potential_value) . "\n" + . $self->_inline_check_constraint($potential_value); + } +} + +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 ) ); +} + +sub _check_new_members_only { + my $self = shift; + + my $attr = $self->associated_attribute; + + my $tc = $attr->type_constraint; + + # If we have a coercion, we could come up with an entirely new value after + # coercing, so we need to check everything, + return 0 if $attr->should_coerce && $tc->has_coercion; + + # If the parent is ArrayRef, that means we can just check the new members + # of the collection, because we know that we will always be generating an + # ArrayRef. + return 1 if $tc->parent->name eq 'ArrayRef'; + + # If our parent is something else ( subtype 'Foo' as 'ArrayRef[Str]' ) + # then there may be additional constraints on the whole value, as opposed + # to constraints just on the members. + return 0; +} + +sub _inline_check_member_constraint { + my ( $self, $new_value ) = @_; + + my $attr_name = $self->associated_attribute->name; + + return '$member_tc->($_) || ' + . $self->_inline_throw_error( + qq{"A new member value for '$attr_name' does not pass its type constraint because: "} + . ' . $member_tc->get_message($_)', + "data => \$_" + ) . " for $new_value;"; +} + +sub _inline_check_coercion { + my ( $self, $value ) = @_; + + my $attr = $self->associated_attribute; + + return '' + unless $attr->should_coerce && $attr->type_constraint->has_coercion; + + # We want to break the aliasing in @_ in case the coercion tries to make a + # destructive change to an array member. + my $code = 'my @copy = @{ $value }'; + return '@_ = @{ $attr->type_constraint->coerce(\@copy) };'; +} + +sub _inline_check_constraint { + my $self = shift; + + return q{} unless $self->_constraint_must_be_checked; + + return $self->SUPER::_inline_check_constraint(@_); +} + +sub _capture_old_value { return q{} } +sub _return_value { return q{} } + +sub _eval_environment { + my $self = shift; + + my $env = $self->SUPER::_eval_environment; + + return $env + unless $self->_constraint_must_be_checked + and $self->_check_new_members_only; + + $env->{'$member_tc'} + = \( $self->associated_attribute->type_constraint->type_parameter + ->_compiled_type_constraint ); + + return $env; +} + 1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm new file mode 100644 index 0000000..d5ad8e7 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm @@ -0,0 +1,102 @@ +package Moose::Meta::Method::Accessor::Native::Array::accessor; + +use strict; +use warnings; + +our $VERSION = '1.13'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +use base qw( + Moose::Meta::Method::Accessor::Native::Array::get + Moose::Meta::Method::Accessor::Native::Array::set +); + +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_curried_arguments; + + $code .= "\n" . $self->_inline_check_lazy($inv); + + my $slot_access = $self->_inline_get($inv); + + # get + $code .= "\n" . 'if ( @_ == 1 ) {'; + + $code .= "\n" . $self->_inline_check_var_is_valid_index('$_[0]'); + + $code .= "\n" . 'return ' . $self->_return_value($slot_access) . ';'; + + # set + $code .= "\n" . '} else {'; + + $code .= "\n" . $self->_inline_check_argument_count; + $code + .= "\n" + . $self + ->Moose::Meta::Method::Accessor::Native::Array::set::_inline_check_arguments; + + my $new_values = $self->_new_values($slot_access); + my $potential_value = $self->_potential_value($slot_access); + + $code .= "\n" + . $self->_inline_tc_code( + $new_values, + $potential_value + ); + + $code .= "\n" . $self->_inline_get_old_value_for_trigger($inv); + $code .= "\n" . $self->_capture_old_value($slot_access); + + $code + .= "\n" . $self->_inline_store( $inv, '[' . $potential_value . ']' ); + + $code .= "\n" . $self->_inline_post_body(@_); + $code .= "\n" . $self->_inline_trigger( $inv, $slot_access, '@old' ); + + $code .= "\n}"; + $code .= "\n}"; + + return $code; +} + +# If we get one argument we won't check the argument count +sub _minimum_arguments {2} +sub _maximum_arguments {2} + +sub _adds_members {1} + +sub _potential_value { + my ( $self, $slot_access ) = @_; + + return + "( do { my \@potential = \@{ $slot_access }; \$potential[ \$_[0] ] = \$_[1]; \@potential } )"; +} + +sub _new_values {'$_[1]'} + +sub _eval_environment { + my $self = shift; + + my $env = $self->SUPER::_eval_environment; + + return $env + unless $self->_constraint_must_be_checked + and $self->_check_new_members_only; + + $env->{'$member_tc'} + = \( $self->associated_attribute->type_constraint->type_parameter + ->_compiled_type_constraint ); + + return $env; +} + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/clear.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/clear.pm new file mode 100644 index 0000000..c991ca5 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/clear.pm @@ -0,0 +1,18 @@ +package Moose::Meta::Method::Accessor::Native::Array::clear; + +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 _maximum_arguments { 0 } + +sub _adds_members { 0 } + +sub _potential_value { return '()' } + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/count.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/count.pm index 148a1b5..36c8de4 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/Array/count.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/count.pm @@ -9,6 +9,8 @@ our $AUTHORITY = 'cpan:STEVAN'; use base 'Moose::Meta::Method::Accessor::Native::Array::Reader'; +sub _maximum_arguments { 0 } + sub _return_value { my $self = shift; my $slot_access = shift; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/delete.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/delete.pm new file mode 100644 index 0000000..c203026 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/delete.pm @@ -0,0 +1,31 @@ +package Moose::Meta::Method::Accessor::Native::Array::delete; + +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 _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _inline_check_arguments { + my $self = shift; + + return $self->_inline_check_var_is_valid_index('$_[0]'); +} + +sub _adds_members { 0 } + +sub _potential_value { + my ( $self, $slot_access ) = @_; + + return + "( do { my \@potential = \@{ $slot_access }; splice \@potential, \$_[0], 1; \@potential } )"; +} + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/elements.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/elements.pm index cc7a81e..29c16bb 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/Array/elements.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/elements.pm @@ -9,6 +9,8 @@ our $AUTHORITY = 'cpan:STEVAN'; use base 'Moose::Meta::Method::Accessor::Native::Array::Reader'; +sub _maximum_arguments { 0 } + sub _return_value { my $self = shift; my $slot_access = shift; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/first.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/first.pm index 510cd3b..6f3cbb8 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/Array/first.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/first.pm @@ -11,20 +11,20 @@ our $AUTHORITY = 'cpan:STEVAN'; use base 'Moose::Meta::Method::Accessor::Native::Array::Reader'; -sub _inline_process_arguments { - return 'my $func = shift;'; -} +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } sub _inline_check_arguments { return - q{die 'Must provide a code reference as an argument' unless ( ref $func || q{} ) eq 'CODE';}; + q{die 'Must provide a code reference as an argument' unless ( ref $_[0] || q{} ) eq 'CODE';}; } sub _return_value { my $self = shift; my $slot_access = shift; - return "&List::Util::first( \$func, \@{ ${slot_access} } )"; + return "&List::Util::first( \$_[0], \@{ ${slot_access} } )"; } 1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/get.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/get.pm index 199deb5..a7b228a 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/Array/get.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/get.pm @@ -9,20 +9,21 @@ our $AUTHORITY = 'cpan:STEVAN'; use base 'Moose::Meta::Method::Accessor::Native::Array::Reader'; -sub _inline_process_arguments { - return 'my $idx = shift;'; -} +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } sub _inline_check_arguments { - return - q{die 'Must provide a valid index number as an argument' unless defined $idx && $idx =~ /^-?\d+$/;}; + my $self = shift; + + return $self->_inline_check_var_is_valid_index('$_[0]'); } sub _return_value { my $self = shift; my $slot_access = shift; - return "${slot_access}->[\$idx]"; + return "${slot_access}->[ \$_[0] ]"; } 1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/grep.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/grep.pm index 7c9d036..5f1df57 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/Array/grep.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/grep.pm @@ -9,20 +9,20 @@ our $AUTHORITY = 'cpan:STEVAN'; use base 'Moose::Meta::Method::Accessor::Native::Array::Reader'; -sub _inline_process_arguments { - return 'my $func = shift;'; -} +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } sub _inline_check_arguments { return - q{die 'Must provide a code reference as an argument' unless ( ref $func || q{} ) eq 'CODE';}; + q{die 'Must provide a code reference as an argument' unless ( ref $_[0] || q{} ) eq 'CODE';}; } sub _return_value { my $self = shift; my $slot_access = shift; - return "grep { \$func->() } \@{ $slot_access }"; + return "grep { \$_[0]->() } \@{ $slot_access }"; } 1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/insert.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/insert.pm new file mode 100644 index 0000000..dd45365 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/insert.pm @@ -0,0 +1,27 @@ +package Moose::Meta::Method::Accessor::Native::Array::insert; + +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 _minimum_arguments { 2 } + +sub _maximum_arguments { 2 } + +sub _adds_members { 1 } + +sub _potential_value { + my ( $self, $slot_access ) = @_; + + return + "( do { my \@potential = \@{ $slot_access }; splice \@potential, \$_[0], 0, \$_[1]; \@potential } )"; +} + +sub _new_values { '$_[1]' } + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/join.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/join.pm index 19333df..600ecb1 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/Array/join.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/join.pm @@ -9,20 +9,20 @@ our $AUTHORITY = 'cpan:STEVAN'; use base 'Moose::Meta::Method::Accessor::Native::Array::Reader'; -sub _inline_process_arguments { - return 'my $sep = shift;'; -} +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } sub _inline_check_arguments { return - q{die 'Must provide a string as an argument' unless defined $sep && ! ref $sep;}; + q{die 'Must provide a string as an argument' unless defined $_[0] && ! ref $_[0];}; } sub _return_value { my $self = shift; my $slot_access = shift; - return "join \$sep, \@{ $slot_access }"; + return "join \$_[0], \@{ $slot_access }"; } 1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/map.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/map.pm index 435472e..29ebd0a 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/Array/map.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/map.pm @@ -9,20 +9,20 @@ our $AUTHORITY = 'cpan:STEVAN'; use base 'Moose::Meta::Method::Accessor::Native::Array::Reader'; -sub _inline_process_arguments { - return 'my $func = shift;'; -} +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } sub _inline_check_arguments { return - q{die 'Must provide a code reference as an argument' unless ( ref $func || q{} ) eq 'CODE';}; + q{die 'Must provide a code reference as an argument' unless ( ref $_[0] || q{} ) eq 'CODE';}; } sub _return_value { my $self = shift; my $slot_access = shift; - return "map { \$func->() } \@{ $slot_access }"; + return "map { \$_[0]->() } \@{ $slot_access }"; } 1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/natatime.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/natatime.pm new file mode 100644 index 0000000..32c68d3 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/natatime.pm @@ -0,0 +1,42 @@ +package Moose::Meta::Method::Accessor::Native::Array::natatime; + +use strict; +use warnings; + +use List::MoreUtils; + +our $VERSION = '1.13'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +use base 'Moose::Meta::Method::Accessor::Native::Array::Reader'; + +sub _minimum_arguments {1} + +sub _maximum_arguments {2} + +sub _inline_check_arguments { + my $self = shift; + + return $self->_inline_throw_error( + q{'Must provide an integer as an argument'}) + . ' unless defined $_[0] && $_[0] =~ /^\\d+$/;' . "\n" + . $self->_inline_throw_error( + q{'The second argument must be a code reference'}) + . q{ if defined $_[1] && ( ref $_[1] || q{} ) ne 'CODE';}; +} + +sub _inline_return_value { + my ( $self, $slot_access ) = @_; + + return + "my \$iter = List::MoreUtils::natatime( \$_[0], \@{ $slot_access } );" + . "\n" + . 'if ( $_[1] ) {' . "\n" + . 'while (my @vals = $iter->()) {' . "\n" + . '$_[1]->(@vals);' . "\n" . '}' . "\n" + . '} else {' . "\n" + . 'return $iter;' . "\n" . '}'; +} + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/pop.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/pop.pm new file mode 100644 index 0000000..a16fb98 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/pop.pm @@ -0,0 +1,39 @@ +package Moose::Meta::Method::Accessor::Native::Array::pop; + +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 _maximum_arguments { 0 } + +sub _adds_members { 0 } + +sub _potential_value { + my ( $self, $slot_access ) = @_; + + return "( \@{ $slot_access } > 1 ? \@{ $slot_access }[ 0 .. \$#{ $slot_access } - 1 ] : () )"; +} + +sub _capture_old_value { + my ( $self, $slot_access ) = @_; + + if ( $self->associated_attribute->has_trigger ) { + return 'my $old = $old[-1];'; + } + else { + return "my \$old = $slot_access;"; + } +} + +sub _return_value { + my ( $self, $instance, $old_value ) = @_; + + return 'return @{$old} ? $old->[-1] : undef;'; +} + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/push.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/push.pm index 8793b65..c2b3125 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/Array/push.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/push.pm @@ -9,50 +9,12 @@ our $AUTHORITY = 'cpan:STEVAN'; use base 'Moose::Meta::Method::Accessor::Native::Array::Writer'; -sub _generate_method { - my $self = shift; +sub _adds_members { 1 } - my $inv = '$self'; +sub _potential_value { + my ( $self, $slot_access ) = @_; - my $slot_access = $self->_inline_get($inv); - - 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_curried_arguments; - - $code - .= "\n" - . $self->_inline_throw_error( - q{"Cannot call push without any arguments"}) - . " unless \@_;"; - - my $potential_new_val; - if ( $self->_constraint_must_be_checked ) { - $code .= "\n" . "my \@new_val = ( \@{ $slot_access }, \@_ );"; - $potential_new_val = '\\@new_val'; - } - else { - $potential_new_val = "[ \@{ $slot_access }, \@_ ];"; - } - - $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, '@_' ); - - $code .= "\n" . $self->_inline_store( $inv, $potential_new_val ); - - $code .= "\n" . $self->_inline_post_body(@_); - $code .= "\n" . $self->_inline_trigger( $inv, '@_', '@old' ); - - $code .= "\n}"; - - return $code; + return "( \@{ $slot_access }, \@_ )"; } 1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/reduce.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/reduce.pm index 94fdf1c..5d5028d 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/Array/reduce.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/reduce.pm @@ -11,20 +11,20 @@ our $AUTHORITY = 'cpan:STEVAN'; use base 'Moose::Meta::Method::Accessor::Native::Array::Reader'; -sub _inline_process_arguments { - return 'my $func = shift;'; -} +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } sub _inline_check_arguments { return - q{die 'Must provide a code reference as an argument' unless ( ref $func || q{} ) eq 'CODE';}; + q{die 'Must provide a code reference as an argument' unless ( ref $_[0] || q{} ) eq 'CODE';}; } sub _return_value { my $self = shift; my $slot_access = shift; - return "List::Util::reduce { \$func->( \$a, \$b ) } \@{ ${slot_access} }"; + return "List::Util::reduce { \$_[0]->( \$a, \$b ) } \@{ ${slot_access} }"; } 1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/set.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/set.pm new file mode 100644 index 0000000..9fdd85b --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/set.pm @@ -0,0 +1,33 @@ +package Moose::Meta::Method::Accessor::Native::Array::set; + +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 _minimum_arguments { 2 } + +sub _maximum_arguments { 2 } + +sub _inline_check_arguments { + my $self = shift; + + return $self->_inline_check_var_is_valid_index('$_[0]'); +} + +sub _adds_members { 1 } + +sub _potential_value { + my ( $self, $slot_access ) = @_; + + return + "( do { my \@potential = \@{ $slot_access }; \$potential[ \$_[0] ] = \$_[1]; \@potential } )"; +} + +sub _new_values { '$_[1]' } + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/shift.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/shift.pm new file mode 100644 index 0000000..f3a7f85 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/shift.pm @@ -0,0 +1,39 @@ +package Moose::Meta::Method::Accessor::Native::Array::shift; + +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 _maximum_arguments { 0 } + +sub _adds_members { 0 } + +sub _potential_value { + my ( $self, $slot_access ) = @_; + + return "( \@{ $slot_access } > 1 ? \@{ $slot_access }[ 1 .. \$#{ $slot_access } ] : () )"; +} + +sub _capture_old_value { + my ( $self, $slot_access ) = @_; + + if ( $self->associated_attribute->has_trigger ) { + return 'my $old = $old[-1];'; + } + else { + return "my \$old = $slot_access;"; + } +} + +sub _return_value { + my ( $self, $instance, $old_value ) = @_; + + return 'return $old->[0]'; +} + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/shuffle.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/shuffle.pm index ca0d67b..465bdd9 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/Array/shuffle.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/shuffle.pm @@ -11,6 +11,8 @@ our $AUTHORITY = 'cpan:STEVAN'; use base 'Moose::Meta::Method::Accessor::Native::Array::Reader'; +sub _maximum_arguments { 0 } + sub _return_value { my $self = shift; my $slot_access = shift; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/sort.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/sort.pm index 338ad1d..d5fce4e 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/Array/sort.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/sort.pm @@ -9,13 +9,11 @@ our $AUTHORITY = 'cpan:STEVAN'; use base 'Moose::Meta::Method::Accessor::Native::Array::Reader'; -sub _inline_process_arguments { - return 'my $func = shift if @_;'; -} +sub _maximum_arguments { 1 } sub _inline_check_arguments { return - q{die 'Argument must be a code reference' if $func && ( ref $func || q{} ) ne 'CODE';}; + q{die 'Argument must be a code reference' if $_[0] && ( ref $_[0] || q{} ) ne 'CODE';}; } sub _return_value { @@ -23,7 +21,7 @@ sub _return_value { my $slot_access = shift; return - "\$func ? sort { \$func->( \$a, \$b ) } \@{ ${slot_access} } : sort \@{ $slot_access }"; + "\$_[0] ? sort { \$_[0]->( \$a, \$b ) } \@{ ${slot_access} } : sort \@{ $slot_access }"; } 1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/sort_in_place.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/sort_in_place.pm new file mode 100644 index 0000000..c5bd8f6 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/sort_in_place.pm @@ -0,0 +1,28 @@ +package Moose::Meta::Method::Accessor::Native::Array::sort_in_place; + +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 _maximum_arguments { 1 } + +sub _inline_check_arguments { + return + q{die 'Argument must be a code reference' if $_[0] && ( ref $_[0] || q{} ) ne 'CODE';}; +} + +sub _adds_members { 0 } + +sub _potential_value { + my ( $self, $slot_access ) = @_; + + return + "( \$_[0] ? sort { \$_[0]->( \$a, \$b ) } \@{ $slot_access } : sort \@{ $slot_access} )"; +} + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/splice.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/splice.pm new file mode 100644 index 0000000..cfccb5f --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/splice.pm @@ -0,0 +1,34 @@ +package Moose::Meta::Method::Accessor::Native::Array::splice; + +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 _minimum_arguments { 1 } + +sub _adds_members { 1 } + +sub _inline_process_arguments { + return 'my $idx = shift;' . "\n" . 'my $len = @_ ? shift : undef;'; +} + +sub _inline_check_arguments { + my $self = shift; + + return $self->_inline_check_var_is_valid_index('$idx') . "\n" + . q{die 'Length must an integer' if defined $len && $len !~ /^-?\\d+$/;}; +} + +sub _potential_value { + my ( $self, $slot_access ) = @_; + + return "( do { my \@potential = \@{ $slot_access };" + . 'defined $len ? ( splice @potential, $idx, $len, @_ ) : ( splice @potential, $idx ); @potential } )'; +} + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/uniq.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/uniq.pm index 1b6de7d..adb394c 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/Array/uniq.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/uniq.pm @@ -11,6 +11,8 @@ our $AUTHORITY = 'cpan:STEVAN'; use base 'Moose::Meta::Method::Accessor::Native::Array::Reader'; +sub _maximum_arguments { 0 } + sub _return_value { my $self = shift; my $slot_access = shift; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/unshift.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/unshift.pm new file mode 100644 index 0000000..27f6b53 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/unshift.pm @@ -0,0 +1,20 @@ +package Moose::Meta::Method::Accessor::Native::Array::unshift; + +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 _adds_members { 1 } + +sub _potential_value { + my ( $self, $slot_access ) = @_; + + return "( \@_, \@{ $slot_access } )"; +} + +1; diff --git a/t/070_native_traits/202_trait_array.t b/t/070_native_traits/202_trait_array.t index b1a1268..46aa9bc 100644 --- a/t/070_native_traits/202_trait_array.t +++ b/t/070_native_traits/202_trait_array.t @@ -3,436 +3,639 @@ use strict; use warnings; +use Moose (); use Test::More; use Test::Exception; -use Test::Moose 'does_ok'; - -my $sort; -my $less; -my $up; -my $prod; - -my %handles = ( - add_options => 'push', - add_options_with_speed => - [ push => 'funrolls', 'funbuns' ], - remove_last_option => 'pop', - remove_first_option => 'shift', - insert_options => 'unshift', - prepend_prerequisites_along_with => - [ unshift => 'first', 'second' ], - get_option_at => 'get', - set_option_at => 'set', - num_options => 'count', - options => 'elements', - has_no_options => 'is_empty', - clear_options => 'clear', - splice_options => 'splice', - sort_options_in_place => 'sort_in_place', - option_accessor => 'accessor', - descending_options => - [ sort_in_place => ( $sort = sub { $_[1] <=> $_[0] } ) ], - map_options => 'map', - up_by_one => [ map => ( $up = sub { $_ + 1 } ) ], - filter_options => 'grep', - less_than_five => [ grep => ( $less = sub { $_ < 5 } ) ], - find_option => 'first', - join_options => 'join', - dashify => [ join => '-' ], - sorted_options => 'sort', - randomized_options => 'shuffle', - unique_options => 'uniq', - pairwise_options => [ natatime => 2 ], - reduce => 'reduce', - product => [ reduce => ( $prod = sub { $_[0] * $_[1] } ) ], -); +use Test::Moose qw( does_ok with_immutable ); { - - package Stuff; - use Moose; - - has '_options' => ( - traits => ['Array'], - is => 'ro', - isa => 'ArrayRef[Str]', - default => sub { [] }, - handles => \%handles, + my %handles = ( + count => 'count', + elements => 'elements', + is_empty => 'is_empty', + push => 'push', + push_curried => + [ push => 42, 84 ], + unshift => 'unshift', + unshift_curried => + [ unshift => 42, 84 ], + pop => 'pop', + shift => 'shift', + get => 'get', + get_curried => [ get => 1 ], + set => 'set', + set_curried_1 => [ set => 1 ], + set_curried_2 => [ set => ( 1, 98 ) ], + accessor => 'accessor', + accessor_curried_1 => [ accessor => 1 ], + accessor_curried_2 => [ accessor => ( 1, 90 ) ], + clear => 'clear', + delete => 'delete', + delete_curried => [ delete => 1 ], + insert => 'insert', + insert_curried => [ insert => ( 1, 101 ) ], + splice => 'splice', + splice_curried_1 => [ splice => 1 ], + splice_curried_2 => [ splice => 1, 2 ], + splice_curried_all => [ splice => 1, 2, ( 3, 4, 5 ) ], + sort => 'sort', + sort_curried => [ sort => ( sub { $_[1] <=> $_[0] } ) ], + sort_in_place => 'sort_in_place', + sort_in_place_curried => + [ sort_in_place => ( sub { $_[1] <=> $_[0] } ) ], + map => 'map', + map_curried => [ map => ( sub { $_ + 1 } ) ], + grep => 'grep', + grep_curried => [ grep => ( sub { $_ < 5 } ) ], + first => 'first', + first_curried => [ first => ( sub { $_ % 2 } ) ], + join => 'join', + join_curried => [ join => '-' ], + shuffle => 'shuffle', + uniq => 'uniq', + reduce => 'reduce', + reduce_curried => [ reduce => ( sub { $_[0] * $_[1] } ) ], + natatime => 'natatime', + natatime_curried => [ natatime => 2 ], ); + + my $name = 'Foo1'; + + sub build_class { + my %attr = @_; + + my $class = Moose::Meta::Class->create( + $name++, + superclasses => ['Moose::Object'], + ); + + $class->add_attribute( + _values => ( + traits => ['Array'], + is => 'rw', + isa => 'ArrayRef[Int]', + default => sub { [] }, + handles => \%handles, + clearer => '_clear_values', + %attr, + ), + ); + + return ( $class->name, \%handles ); + } } { - my $stuff = Stuff->new( _options => [ 10, 12 ] ); - isa_ok( $stuff, 'Stuff' ); + run_tests(build_class); + run_tests( build_class( lazy => 1, default => sub { [ 42, 84 ] } ) ); +} - can_ok( $stuff, $_ ) for sort keys %handles; +sub run_tests { + my ( $class, $handles ) = @_; - is_deeply( $stuff->_options, [ 10, 12 ], '... got options' ); + can_ok( $class, $_ ) for sort keys %{$handles}; - ok( !$stuff->has_no_options, '... we have options' ); - is( $stuff->num_options, 2, '... got 2 options' ); + with_immutable { + my $obj = $class->new( _values => [ 10, 12, 42 ] ); - is( $stuff->remove_last_option, 12, '... removed the last option' ); - is( $stuff->remove_first_option, 10, '... removed the last option' ); + is_deeply( + $obj->_values, [ 10, 12, 42 ], + 'values can be set in constructor' + ); - is_deeply( $stuff->_options, [], '... no options anymore' ); + ok( !$obj->is_empty, 'values is not empty' ); + is( $obj->count, 3, 'count returns 3' ); - ok( $stuff->has_no_options, '... no options' ); - is( $stuff->num_options, 0, '... got no options' ); + throws_ok { $obj->count(22) } + qr/Cannot call count with any arguments/, + 'throws an error with when passing an argument to count'; - lives_ok { - $stuff->add_options( 1, 2, 3 ); - } - '... set the option okay'; + lives_ok { $obj->push( 1, 2, 3 ) } + 'pushed three new values and lived'; - is_deeply( $stuff->_options, [ 1, 2, 3 ], '... got options now' ); - is_deeply( - [ $stuff->options ], [ 1, 2, 3 ], - '... got options now (with elements method)' - ); + lives_ok { $obj->push() } 'call to push without arguments lives'; - ok( !$stuff->has_no_options, '... has options' ); - is( $stuff->num_options, 3, '... got 3 options' ); + lives_ok { $obj->unshift( 101, 22 ) } + 'unshifted two values and lived'; - is( $stuff->get_option_at(0), 1, '... get option at index 0' ); - is( $stuff->get_option_at(1), 2, '... get option at index 1' ); - is( $stuff->get_option_at(2), 3, '... get option at index 2' ); + lives_ok { $obj->unshift() } + 'call to unshift without arguments lives'; - throws_ok { $stuff->get_option_at() } - qr/Must provide a valid index number as an argument/, - 'throws an error when get_option_at is called without any arguments'; + is( $obj->pop, 3, 'pop returns the last value in the array' ); - throws_ok { $stuff->get_option_at( {} ) } - qr/Must provide a valid index number as an argument/, - 'throws an error when get_option_at is called with an invalid argument'; + is_deeply( + $obj->_values, [ 101, 22, 10, 12, 42, 1, 2 ], + 'pop changed the value of the array in the object' + ); - throws_ok { $stuff->get_option_at(2.2) } - qr/Must provide a valid index number as an argument/, - 'throws an error when get_option_at is called with an invalid argument'; + throws_ok { $obj->pop(42) } + qr/Cannot call pop with any arguments/, + 'call to pop with arguments dies'; - throws_ok { $stuff->get_option_at('foo') } - qr/Must provide a valid index number as an argument/, - 'throws an error when get_option_at is called with an invalid argument'; + is( $obj->shift, 101, 'shift returns the first value' ); - lives_ok { - $stuff->set_option_at( 1, 100 ); - } - '... set the option okay'; + throws_ok { $obj->shift(42) } + qr/Cannot call shift with any arguments/, + 'call to shift with arguments dies'; - is( $stuff->get_option_at(1), 100, '... get option at index 1' ); + is_deeply( + $obj->_values, [ 22, 10, 12, 42, 1, 2 ], + 'shift changed the value of the array in the object' + ); - lives_ok { - $stuff->add_options( 10, 15 ); - } - '... set the option okay'; + is_deeply( + [ $obj->elements ], [ 22, 10, 12, 42, 1, 2 ], + 'call to elements returns values as a list' + ); - is_deeply( - $stuff->_options, [ 1, 100, 3, 10, 15 ], - '... got more options now' - ); + throws_ok { $obj->elements(22) } + qr/Cannot call elements with any arguments/, + 'throws an error with when passing an argument to elements'; - is( $stuff->num_options, 5, '... got 5 options' ); + $obj->_values( [ 1, 2, 3 ] ); - is( $stuff->remove_last_option, 15, '... removed the last option' ); + is( $obj->get(0), 1, 'get values at index 0' ); + is( $obj->get(1), 2, 'get values at index 1' ); + is( $obj->get(2), 3, 'get values at index 2' ); + is( $obj->get_curried, 2, 'get_curried returns value at index 1' ); - is( $stuff->num_options, 4, '... got 4 options' ); - is_deeply( - $stuff->_options, [ 1, 100, 3, 10 ], - '... got diff options now' - ); + throws_ok { $obj->get() } + qr/Cannot call get without at least 1 argument/, + 'throws an error when get is called without any arguments'; - lives_ok { - $stuff->insert_options( 10, 20 ); - } - '... set the option okay'; + throws_ok { $obj->get( {} ) } + qr/Must provide a valid index number as an argument/, + 'throws an error when get is called with an invalid argument'; - is( $stuff->num_options, 6, '... got 6 options' ); - is_deeply( - $stuff->_options, [ 10, 20, 1, 100, 3, 10 ], - '... got diff options now' - ); + throws_ok { $obj->get(2.2) } + qr/Must provide a valid index number as an argument/, + 'throws an error when get is called with an invalid argument'; - is( $stuff->get_option_at(0), 10, '... get option at index 0' ); - is( $stuff->get_option_at(1), 20, '... get option at index 1' ); - is( $stuff->get_option_at(3), 100, '... get option at index 3' ); + throws_ok { $obj->get('foo') } + qr/Must provide a valid index number as an argument/, + 'throws an error when get is called with an invalid argument'; - is( $stuff->remove_first_option, 10, '... getting the first option' ); + throws_ok { $obj->get_curried(2) } + qr/Cannot call get with more than 1 argument/, + 'throws an error when get_curried is called with an argument'; - is( $stuff->num_options, 5, '... got 5 options' ); - is( $stuff->get_option_at(0), 20, '... get option at index 0' ); + lives_ok { $obj->set( 1, 100 ) } 'set value at index 1 lives'; - $stuff->clear_options; - is_deeply( $stuff->_options, [], "... clear options" ); + is( $obj->get(1), 100, 'get value at index 1 returns new value' ); - $stuff->add_options( 5, 1, 2, 3 ); - $stuff->sort_options_in_place; - is_deeply( - $stuff->_options, [ 1, 2, 3, 5 ], - "... sort options in place (default sort order)" - ); + throws_ok { $obj->set( 1, 99, 42 ) } + qr/Cannot call set with more than 2 arguments/, + 'throws an error when set is called with three arguments'; - $stuff->sort_options_in_place( sub { $_[1] <=> $_[0] } ); - is_deeply( - $stuff->_options, [ 5, 3, 2, 1 ], - "... sort options in place (descending order)" - ); + lives_ok { $obj->set_curried_1(99) } 'set_curried_1 lives'; - $stuff->clear_options(); - $stuff->add_options( 5, 1, 2, 3 ); - lives_ok { - $stuff->descending_options(); - } - '... curried sort in place lives ok'; + is( $obj->get(1), 99, 'get value at index 1 returns new value' ); - is_deeply( $stuff->_options, [ 5, 3, 2, 1 ], "... sort currying" ); + throws_ok { $obj->set_curried_1( 99, 42 ) } + qr/Cannot call set with more than 2 arguments/, + 'throws an error when set_curried_1 is called with two arguments'; - throws_ok { $stuff->sort_options_in_place('foo') } - qr/Argument must be a code reference/, - 'error when sort_in_place receives a non-coderef argument'; + lives_ok { $obj->set_curried_2 } 'set_curried_2 lives'; - $stuff->clear_options; + is( $obj->get(1), 98, 'get value at index 1 returns new value' ); - lives_ok { - $stuff->add_options('tree'); - } - '... set the options okay'; + throws_ok { $obj->set_curried_2(42) } + qr/Cannot call set with more than 2 arguments/, + 'throws an error when set_curried_2 is called with one argument'; - lives_ok { - $stuff->add_options_with_speed( 'compatible', 'safe' ); - } - '... add options with speed okay'; + is( + $obj->accessor(1), 98, + 'accessor with one argument returns value at index 1' + ); - is_deeply( - $stuff->_options, [qw/tree funrolls funbuns compatible safe/], - 'check options after add_options_with_speed' - ); + lives_ok { $obj->accessor( 1 => 97 ) } 'accessor as writer lives'; - lives_ok { - $stuff->prepend_prerequisites_along_with(); - } - '... add prerequisite options okay'; + is( + $obj->get(1), 97, + 'accessor set value at index 1' + ); - $stuff->clear_options; - $stuff->add_options( 1, 2 ); + throws_ok { $obj->accessor( 1, 96, 42 ) } + qr/Cannot call accessor with more than 2 arguments/, + 'throws an error when accessor is called with three arguments'; - lives_ok { - $stuff->splice_options( 1, 0, 'foo' ); - } - '... splice_options works'; + is( + $obj->accessor_curried_1, 97, + 'accessor_curried_1 returns expected value when called with no arguments' + ); - is_deeply( - $stuff->_options, [ 1, 'foo', 2 ], - 'splice added expected option' - ); + lives_ok { $obj->accessor_curried_1(95) } + 'accessor_curried_1 as writer lives'; - is( - $stuff->option_accessor( 1 => 'foo++' ), 'foo++', - 'set using accessor method' - ); - is( $stuff->option_accessor(1), 'foo++', 'get using accessor method' ); + is( + $obj->get(1), 95, + 'accessor_curried_1 set value at index 1' + ); - dies_ok { - $stuff->insert_options(undef); - } - '... could not add an undef where a string is expected'; + throws_ok { $obj->accessor_curried_1( 96, 42 ) } + qr/Cannot call accessor with more than 2 arguments/, + 'throws an error when accessor_curried_1 is called with two arguments'; - dies_ok { - $stuff->set_option( 5, {} ); - } - '... could not add a hash ref where a string is expected'; + lives_ok { $obj->accessor_curried_2 } + 'accessor_curried_2 as writer lives'; - dies_ok { - Stuff->new( _options => [ undef, 10, undef, 20 ] ); - } - '... bad constructor params'; + is( + $obj->get(1), 90, + 'accessor_curried_2 set value at index 1' + ); - dies_ok { - my $stuff = Stuff->new(); - $stuff->add_options(undef); - } - '... rejects push of an invalid type'; + throws_ok { $obj->accessor_curried_2(42) } + qr/Cannot call accessor with more than 2 arguments/, + 'throws an error when accessor_curried_2 is called with one argument'; - dies_ok { - my $stuff = Stuff->new(); - $stuff->insert_options(undef); - } - '... rejects unshift of an invalid type'; + lives_ok { $obj->clear } 'clear lives'; - dies_ok { - my $stuff = Stuff->new(); - $stuff->set_option_at( 0, undef ); - } - '... rejects set of an invalid type'; + ok( $obj->is_empty, 'values is empty after call to clear' ); - dies_ok { - my $stuff = Stuff->new(); - $stuff->sort_in_place_options(undef); - } - '... sort rejects arg of invalid type'; + $obj->set( 0 => 42 ); - dies_ok { - my $stuff = Stuff->new(); - $stuff->option_accessor(); - } - '... accessor rejects 0 args'; + throws_ok { $obj->clear(50) } + qr/Cannot call clear with any arguments/, + 'throws an error when clear is called with an argument'; - dies_ok { - my $stuff = Stuff->new(); - $stuff->option_accessor( 1, 2, 3 ); - } - '... accessor rejects 3 args'; -} + ok( + !$obj->is_empty, + 'values is not empty after failed call to clear' + ); -{ - my $stuff = Stuff->new( _options => [ 1 .. 10 ] ); + $obj->clear; + $obj->push( 1, 5, 10, 42 ); - is_deeply( $stuff->_options, [ 1 .. 10 ], '... got options' ); + lives_ok { $obj->delete(2) } 'delete lives'; - ok( !$stuff->has_no_options, '... we have options' ); - is( $stuff->num_options, 10, '... got 2 options' ); - cmp_ok( $stuff->get_option_at(0), '==', 1, '... get option 0' ); + is_deeply( + $obj->_values, [ 1, 5, 42 ], + 'delete removed the specified element' + ); - is_deeply( - [ $stuff->filter_options( sub { $_ % 2 == 0 } ) ], - [ 2, 4, 6, 8, 10 ], - '... got the right filtered values' - ); + throws_ok { $obj->delete( 2, 3 ) } + qr/Cannot call delete with more than 1 argument/, + 'throws an error when delete is called with two arguments'; - throws_ok { $stuff->filter_options() } - qr/Must provide a code reference as an argument/, - 'throws an error when filter_options is called without any arguments'; + lives_ok { $obj->delete_curried } 'delete_curried lives'; - throws_ok { $stuff->filter_options( {} ) } - qr/Must provide a code reference as an argument/, - 'throws an error when filter_options is called with an invalid argument'; + is_deeply( + $obj->_values, [ 1, 42 ], + 'delete removed the specified element' + ); - is_deeply( - [ $stuff->map_options( sub { $_ * 2 } ) ], - [ 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 ], - '... got the right mapped values' - ); + throws_ok { $obj->delete_curried(2) } + qr/Cannot call delete with more than 1 argument/, + 'throws an error when delete_curried is called with one argument'; - throws_ok { $stuff->map_options() } - qr/Must provide a code reference as an argument/, - 'throws an error when map_options is called without any arguments'; + lives_ok { $obj->insert( 1, 21 ) } 'insert lives'; - throws_ok { $stuff->map_options( {} ) } - qr/Must provide a code reference as an argument/, - 'throws an error when map_options is called with an invalid argument'; + is_deeply( + $obj->_values, [ 1, 21, 42 ], + 'insert added the specified element' + ); - is( - $stuff->find_option( sub { $_ % 2 == 0 } ), 2, - '.. found the right option' - ); + throws_ok { $obj->insert( 1, 22, 44 ) } + qr/Cannot call insert with more than 2 arguments/, + 'throws an error when insert is called with three arguments'; - throws_ok { $stuff->find_option() } - qr/Must provide a code reference as an argument/, - 'throws an error when find_option is called without any arguments'; + lives_ok { $obj->splice( 1, 0, 2, 3 ) } 'splice lives'; - throws_ok { $stuff->find_option( {} ) } - qr/Must provide a code reference as an argument/, - 'throws an error when find_option is called with an invalid argument'; + is_deeply( + $obj->_values, [ 1, 2, 3, 21, 42 ], + 'splice added the specified elements' + ); - is_deeply( - [ $stuff->options ], [ 1 .. 10 ], - '... got the list of options' - ); + lives_ok { $obj->splice( 1, 1, 99 ) } 'splice lives'; - is( - $stuff->join_options(':'), '1:2:3:4:5:6:7:8:9:10', - '... joined the list of options by :' - ); + is_deeply( + $obj->_values, [ 1, 99, 3, 21, 42 ], + 'splice added the specified elements' + ); - throws_ok { $stuff->join_options() } - qr/Must provide a string as an argument/, - 'throws an error when join_options is called without any arguments'; + throws_ok { $obj->splice() } + qr/Cannot call splice without at least 1 argument/, + 'throws an error when splice is called with no arguments'; - throws_ok { $stuff->join_options( {} ) } - qr/Must provide a string as an argument/, - 'throws an error when join_options is called with an invalid argument'; + lives_ok { $obj->splice_curried_1( 2, 101 ) } + 'splice_curried_1 lives'; - is_deeply( - [ $stuff->sorted_options ], [ sort ( 1 .. 10 ) ], - '... got sorted options (default sort order)' - ); - is_deeply( - [ $stuff->sorted_options( sub { $_[1] <=> $_[0] } ) ], - [ sort { $b <=> $a } ( 1 .. 10 ) ], - '... got sorted options (descending sort order) ' - ); + is_deeply( + $obj->_values, [ 1, 101, 21, 42 ], + 'splice added the specified elements' + ); - throws_ok { $stuff->sorted_options('foo') } - qr/Argument must be a code reference/, - 'error when sort receives a non-coderef argument'; + lives_ok { $obj->splice_curried_2(102) } 'splice_curried_2 lives'; - is_deeply( - [ sort { $a <=> $b } $stuff->randomized_options ], - [ 1 .. 10 ], - 'randomized_options returns all options' - ); + is_deeply( + $obj->_values, [ 1, 102, 42 ], + 'splice added the specified elements' + ); - my @pairs; - $stuff->pairwise_options( sub { push @pairs, [@_] } ); - is_deeply( - \@pairs, - [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ], [ 7, 8 ], [ 9, 10 ] ], - 'pairwise returns pairs as expected' - ); + lives_ok { $obj->splice_curried_all } 'splice_curried_all lives'; - is_deeply( - [ $stuff->less_than_five() ], [ 1 .. 4 ], - 'less_than_five returns 1..4' - ); + is_deeply( + $obj->_values, [ 1, 3, 4, 5 ], + 'splice added the specified elements' + ); - is_deeply( - [ $stuff->up_by_one() ], [ 2 .. 11 ], - 'up_by_one returns 2..11' - ); + $obj->_values( [ 3, 9, 5, 22, 11 ] ); - is( - $stuff->dashify, '1-2-3-4-5-6-7-8-9-10', - 'dashify returns options joined by dashes' - ); + is_deeply( + [ $obj->sort ], [ 11, 22, 3, 5, 9 ], + 'sort returns sorted values' + ); - is( - $stuff->reduce( sub { $_[0] * $_[1] } ), - 3628800, - 'call reducing to generate a product returns expected value' - ); + is_deeply( + [ $obj->sort( sub { $_[0] <=> $_[1] } ) ], [ 3, 5, 9, 11, 22 ], + 'sort returns values sorted by provided function' + ); - throws_ok { $stuff->reduce() } - qr/Must provide a code reference as an argument/, - 'throws an error when reduce is called without any arguments'; + throws_ok { $obj->sort(1) } + qr/Argument must be a code reference/, + 'throws an error with when passing a non-function to sort'; - throws_ok { $stuff->reduce( {} ) } - qr/Must provide a code reference as an argument/, - 'throws an error when reduce is called with an invalid argument'; + throws_ok { + $obj->sort( sub { }, 27 ); + } + qr/Cannot call sort with more than 1 argument/, + 'throws an error with when passing two arguments to sort'; - is( - $stuff->product, 3628800, - 'product returns expected value' - ); + $obj->_values( [ 3, 9, 5, 22, 11 ] ); - my $other_stuff = Stuff->new( _options => [ 1, 1, 2, 3, 5 ] ); - is_deeply( - [ $other_stuff->unique_options ], [ 1, 2, 3, 5 ], - 'unique_options returns unique options' - ); -} + $obj->sort_in_place; -{ - my $options = Stuff->meta->get_attribute('_options'); - does_ok( $options, 'Moose::Meta::Attribute::Native::Trait::Array' ); + is_deeply( + $obj->_values, [ 11, 22, 3, 5, 9 ], + 'sort_in_place sorts values' + ); - is_deeply( - $options->handles, \%handles, - '... got the right handles mapping' - ); + $obj->sort_in_place( sub { $_[0] <=> $_[1] } ); - is( - $options->type_constraint->type_parameter, 'Str', - '... got the right container type' - ); + is_deeply( + $obj->_values, [ 3, 5, 9, 11, 22 ], + 'sort_in_place with function sorts values' + ); + + throws_ok { + $obj->sort_in_place( sub { }, 27 ); + } + qr/Cannot call sort_in_place with more than 1 argument/, + 'throws an error with when passing two arguments to sort_in_place'; + + $obj->_values( [ 3, 9, 5, 22, 11 ] ); + + $obj->sort_in_place_curried; + + is_deeply( + $obj->_values, [ 22, 11, 9, 5, 3 ], + 'sort_in_place_curried sorts values' + ); + + throws_ok { $obj->sort_in_place_curried(27) } + qr/Cannot call sort_in_place with more than 1 argument/, + 'throws an error with when passing one argument to sort_in_place_curried'; + + $obj->_values( [ 1 .. 5 ] ); + + is_deeply( + [ $obj->map( sub { $_ + 1 } ) ], + [ 2 .. 6 ], + 'map returns the expected values' + ); + + throws_ok { $obj->map } + qr/Cannot call map without at least 1 argument/, + 'throws an error with when passing no arguments to map'; + + throws_ok { + $obj->map( sub { }, 2 ); + } + qr/Cannot call map with more than 1 argument/, + 'throws an error with when passing two arguments to map'; + + throws_ok { $obj->map( {} ) } + qr/Must provide a code reference as an argument/, + 'throws an error with when passing a non coderef to map'; + + $obj->_values( [ 1 .. 5 ] ); + + is_deeply( + [ $obj->map_curried ], + [ 2 .. 6 ], + 'map_curried returns the expected values' + ); + + throws_ok { + $obj->map_curried( sub { } ); + } + qr/Cannot call map with more than 1 argument/, + 'throws an error with when passing one argument to map_curried'; + + $obj->_values( [ 2 .. 9 ] ); + + is_deeply( + [ $obj->grep( sub { $_ < 5 } ) ], + [ 2 .. 4 ], + 'grep returns the expected values' + ); + + throws_ok { $obj->grep } + qr/Cannot call grep without at least 1 argument/, + 'throws an error with when passing no arguments to grep'; + + throws_ok { + $obj->grep( sub { }, 2 ); + } + qr/Cannot call grep with more than 1 argument/, + 'throws an error with when passing two arguments to grep'; + + throws_ok { $obj->grep( {} ) } + qr/Must provide a code reference as an argument/, + 'throws an error with when passing a non coderef to grep'; + + is_deeply( + [ $obj->grep_curried ], + [ 2 .. 4 ], + 'grep_curried returns the expected values' + ); + + throws_ok { + $obj->grep_curried( sub { } ); + } + qr/Cannot call grep with more than 1 argument/, + 'throws an error with when passing one argument to grep_curried'; + + $obj->_values( [ 2, 4, 22, 99, 101, 6 ] ); + + is( + $obj->first( sub { $_ % 2 } ), + 99, + 'first returns expected value' + ); + + throws_ok { $obj->first } + qr/Cannot call first without at least 1 argument/, + 'throws an error with when passing no arguments to first'; + + throws_ok { + $obj->first( sub { }, 2 ); + } + qr/Cannot call first with more than 1 argument/, + 'throws an error with when passing two arguments to first'; + + throws_ok { $obj->first( {} ) } + qr/Must provide a code reference as an argument/, + 'throws an error with when passing a non coderef to first'; + + is( + $obj->first_curried, + 99, + 'first_curried returns expected value' + ); + + throws_ok { + $obj->first_curried( sub { } ); + } + qr/Cannot call first with more than 1 argument/, + 'throws an error with when passing one argument to first_curried'; + + $obj->_values( [ 1 .. 4 ] ); + + is( + $obj->join('-'), '1-2-3-4', + 'join returns expected result' + ); + + throws_ok { $obj->join } + qr/Cannot call join without at least 1 argument/, + 'throws an error with when passing no arguments to join'; + + throws_ok { $obj->join( '-', 2 ) } + qr/Cannot call join with more than 1 argument/, + 'throws an error with when passing two arguments to join'; + + throws_ok { $obj->join( {} ) } + qr/Must provide a string as an argument/, + 'throws an error with when passing a non string to join'; + + is_deeply( + [ sort $obj->shuffle ], + [ 1 .. 4 ], + 'shuffle returns all values (cannot check for a random order)' + ); + + throws_ok { $obj->shuffle(2) } + qr/Cannot call shuffle with any arguments/, + 'throws an error with when passing an argument to shuffle'; + + $obj->_values( [ 1 .. 4, 2, 5, 3, 7, 3, 3, 1 ] ); + + is_deeply( + [ $obj->uniq ], + [ 1 .. 4, 5, 7 ], + 'uniq returns expected values (in original order)' + ); + + throws_ok { $obj->uniq(2) } + qr/Cannot call uniq with any arguments/, + 'throws an error with when passing an argument to uniq'; + + $obj->_values( [ 1 .. 5 ] ); + + is( + $obj->reduce( sub { $_[0] * $_[1] } ), + 120, + 'reduce returns expected value' + ); + + throws_ok { $obj->reduce } + qr/Cannot call reduce without at least 1 argument/, + 'throws an error with when passing no arguments to reduce'; + + throws_ok { + $obj->reduce( sub { }, 2 ); + } + qr/Cannot call reduce with more than 1 argument/, + 'throws an error with when passing two arguments to reduce'; + + throws_ok { $obj->reduce( {} ) } + qr/Must provide a code reference as an argument/, + 'throws an error with when passing a non coderef to reduce'; + + is( + $obj->reduce_curried, + 120, + 'reduce_curried returns expected value' + ); + + throws_ok { + $obj->reduce_curried( sub { } ); + } + qr/Cannot call reduce with more than 1 argument/, + 'throws an error with when passing one argument to reduce_curried'; + + $obj->_values( [ 1 .. 6 ] ); + + my $it = $obj->natatime(2); + my @nat; + while ( my @v = $it->() ) { + push @nat, \@v; + } + + is_deeply( + [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], + \@nat, + 'natatime returns expected iterator' + ); + + @nat = (); + $obj->natatime( 2, sub { push @nat, [@_] } ); + + is_deeply( + [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], + \@nat, + 'natatime with function returns expected value' + ); + + throws_ok { $obj->natatime( {} ) } + qr/Must provide an integer as an argument/, + 'throws an error with when passing a non integer to natatime'; + + throws_ok { $obj->natatime( 2, {} ) } + qr/The second argument must be a code reference/, + 'throws an error with when passing a non code ref to natatime'; + + if ( $class->meta->get_attribute('_values')->is_lazy ) { + my $obj = $class->new; + + is( $obj->count, 2, 'count is 2 (lazy init)' ); + + $obj->_clear_values; + + is_deeply( [ $obj->elements ], [ 42, 84], + 'elements contains default with lazy init' ); + + $obj->_clear_values; + + $obj->push(2); + + is_deeply( + $obj->_values, [ 42, 84, 2 ], + 'push works with lazy init' + ); + + $obj->_clear_values; + + $obj->unshift( 3, 4 ); + + is_deeply( + $obj->_values, [ 3, 4, 42, 84 ], + 'unshift works with lazy init' + ); + } + } + $class; } done_testing;