Made sure we had tests for all of them, including tests for failure cases.
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
-sub reduce : method {
- my ( $attr, $reader, $writer ) = @_;
- return sub {
- my ( $instance, $f ) = @_;
- our ($a, $b);
- List::Util::reduce { $f->($a, $b) } @{ $reader->($instance) };
- };
-}
-
-sub sort : method {
- my ( $attr, $reader, $writer ) = @_;
- return sub {
- my ( $instance, $predicate ) = @_;
- die "Argument must be a code reference"
- if $predicate && ref $predicate ne 'CODE';
-
- if ($predicate) {
- # Although it would be nice if we could support just using $a and
- # $b like sort already does, using $a or $b once in a package
- # triggers the 'Name "main::a" used only once' warning, and there
- # is no good way to avoid that, since it happens when the file
- # which defines the coderef is compiled, before we even get a
- # chance to see it here. So, we have no real choice but to use
- # normal parameters. --doy
- CORE::sort { $predicate->( $a, $b ) } @{ $reader->($instance) };
- }
- else {
- CORE::sort @{ $reader->($instance) };
- }
- };
-}
-
-sub shuffle : method {
- my ( $attr, $reader, $writer ) = @_;
- return sub {
- my ( $instance ) = @_;
- List::Util::shuffle @{ $reader->($instance) };
- };
-}
-
-sub grep : method {
- my ( $attr, $reader, $writer ) = @_;
- return sub {
- my ( $instance, $predicate ) = @_;
- CORE::grep { $predicate->() } @{ $reader->($instance) };
- };
-}
-
-sub uniq : method {
- my ( $attr, $reader, $writer ) = @_;
- return sub {
- my ( $instance ) = @_;
- List::MoreUtils::uniq @{ $reader->($instance) };
- };
-}
-
-sub join : method {
- my ( $attr, $reader, $writer ) = @_;
- return sub {
- my ( $instance, $separator ) = @_;
- join $separator, @{ $reader->($instance) };
- };
-}
-
-sub push : 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::push @{ $reader->($instance) } => @_;
- };
- }
- else {
- return sub {
- my $instance = CORE::shift;
- CORE::push @{ $reader->($instance) } => @_;
- };
- }
-}
-
sub pop : method {
my ( $attr, $reader, $writer ) = @_;
return sub {
};
}
-sub get : method {
- my ( $attr, $reader, $writer ) = @_;
- return sub {
- $reader->( $_[0] )->[ $_[1] ];
- };
-}
-
sub set : method {
my ( $attr, $reader, $writer ) = @_;
if (
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::get;
+use Moose::Meta::Method::Accessor::Native::Array::grep;
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::push;
+use Moose::Meta::Method::Accessor::Native::Array::reduce;
+use Moose::Meta::Method::Accessor::Native::Array::shuffle;
+use Moose::Meta::Method::Accessor::Native::Array::sort;
+use Moose::Meta::Method::Accessor::Native::Array::uniq;
with 'Moose::Meta::Attribute::Native::Trait';
|| ( $attr->should_coerce && $attr->type_constraint->has_coercion ) );
}
+sub _inline_process_arguments { q{} }
+
+sub _inline_check_arguments { q{} }
+
1;
$code .= "\n" . 'my $self = shift;';
$code .= "\n" . $self->_inline_curried_arguments;
$code .= "\n" . $self->_inline_process_arguments;
+ $code .= "\n" . $self->_inline_check_arguments;
$code
.= "\n"
return $code;
}
-sub _inline_process_arguments { q{} }
-
1;
use base 'Moose::Meta::Method::Accessor::Native::Array::Reader';
sub _return_value {
- my $self = shift;
+ my $self = shift;
my $slot_access = shift;
return "\@{ $slot_access }";
return 'my $func = shift;';
}
+sub _inline_check_arguments {
+ return
+ q{die 'Must provide a code reference as an argument' unless ( ref $func || q{} ) eq 'CODE';};
+}
+
sub _return_value {
my $self = shift;
my $slot_access = shift;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::Array::get;
+
+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 $idx = shift;';
+}
+
+sub _inline_check_arguments {
+ return
+ q{die 'Must provide a valid index number as an argument' unless defined $idx && $idx =~ /^-?\d+$/;};
+}
+
+sub _return_value {
+ my $self = shift;
+ my $slot_access = shift;
+
+ return "${slot_access}->[\$idx]";
+}
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::Array::grep;
+
+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 _inline_check_arguments {
+ return
+ q{die 'Must provide a code reference as an argument' unless ( ref $func || q{} ) eq 'CODE';};
+}
+
+sub _return_value {
+ my $self = shift;
+ my $slot_access = shift;
+
+ return "grep { \$func->() } \@{ $slot_access }";
+}
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::Array::join;
+
+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 $sep = shift;';
+}
+
+sub _inline_check_arguments {
+ return
+ q{die 'Must provide a string as an argument' unless defined $sep && ! ref $sep;};
+}
+
+sub _return_value {
+ my $self = shift;
+ my $slot_access = shift;
+
+ return "join \$sep, \@{ $slot_access }";
+}
+
+1;
return 'my $func = shift;';
}
+sub _inline_check_arguments {
+ return
+ q{die 'Must provide a code reference as an argument' unless ( ref $func || q{} ) eq 'CODE';};
+}
+
sub _return_value {
my $self = shift;
my $slot_access = shift;
$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_get_old_value_for_trigger( $inv, '@_' );
$code .= "\n" . $self->_inline_store( $inv, $potential_new_val );
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::Array::reduce;
+
+use strict;
+use warnings;
+
+use List::Util ();
+
+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 _inline_check_arguments {
+ return
+ q{die 'Must provide a code reference as an argument' unless ( ref $func || q{} ) eq 'CODE';};
+}
+
+sub _return_value {
+ my $self = shift;
+ my $slot_access = shift;
+
+ return "List::Util::reduce { \$func->( \$a, \$b ) } \@{ ${slot_access} }";
+}
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::Array::shuffle;
+
+use strict;
+use warnings;
+
+use List::Util ();
+
+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 "List::Util::shuffle \@{ $slot_access }";
+}
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::Array::sort;
+
+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 if @_;';
+}
+
+sub _inline_check_arguments {
+ return
+ q{die 'Argument must be a code reference' if $func && ( ref $func || q{} ) ne 'CODE';};
+}
+
+sub _return_value {
+ my $self = shift;
+ my $slot_access = shift;
+
+ return
+ "\$func ? sort { \$func->( \$a, \$b ) } \@{ ${slot_access} } : sort \@{ $slot_access }";
+}
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::Array::uniq;
+
+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 _return_value {
+ my $self = shift;
+ my $slot_access = shift;
+
+ return "List::MoreUtils::uniq \@{ $slot_access }";
+}
+
+1;
is( $stuff->get_option_at(1), 2, '... get option at index 1' );
is( $stuff->get_option_at(2), 3, '... get option at index 2' );
+ 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';
+
+ 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';
+
+ 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 { $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';
+
lives_ok {
$stuff->set_option_at( 1, 100 );
}
'... got the right filtered values'
);
+ 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';
+
+ 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(
[ $stuff->map_options( sub { $_ * 2 } ) ],
[ 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 ],
'... got the right mapped values'
);
+ 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';
+
+ 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(
$stuff->find_option( sub { $_ % 2 == 0 } ), 2,
'.. found the right option'
);
+ 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';
+
+ 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(
[ $stuff->options ], [ 1 .. 10 ],
'... got the list of options'
'... joined the list of options by :'
);
+ 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 { $stuff->join_options( {} ) }
+ qr/Must provide a string as an argument/,
+ 'throws an error when join_options is called with an invalid argument';
+
is_deeply(
[ $stuff->sorted_options ], [ sort ( 1 .. 10 ) ],
'... got sorted options (default sort order)'
);
is(
+ $stuff->reduce( sub { $_[0] * $_[1] } ),
+ 3628800,
+ 'call reducing to generate a product returns expected value'
+ );
+
+ 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 { $stuff->reduce( {} ) }
+ qr/Must provide a code reference as an argument/,
+ 'throws an error when reduce is called with an invalid argument';
+
+ is(
$stuff->product, 3628800,
'product returns expected value'
);
projects / gitmo/Moose.git / commitdiff