list (there are technical limitations to using C<$a> and C<$b> like C<sort>
does).
+=item Several new helpers from L<List::Util> and L<List::MoreUtils> were added
+
+In particular, we now have C<reduce>, C<shuffle>, C<uniq>, and C<natatime>.
+
=back
See L<Moose::Meta::Attribute::Native> for the new documentation.
package Moose::Meta::Attribute::Native::MethodProvider::Array;
use Moose::Role;
+use List::Util;
+use List::MoreUtils;
+
our $VERSION = '0.89';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
my ( $attr, $reader, $writer ) = @_;
return sub {
my ( $instance, $predicate ) = @_;
- foreach my $val ( @{ $reader->($instance) } ) {
- local $_ = $val;
- return $val if $predicate->();
- }
- return;
+ &List::Util::first($predicate, @{ $reader->($instance) });
};
}
};
}
+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 {
};
}
+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 {
};
}
+sub uniq : method {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub {
+ my ( $instance ) = @_;
+ List::MoreUtils::uniq @{ $reader->($instance) };
+ };
+}
+
sub elements : method {
my ( $attr, $reader, $writer ) = @_;
return sub {
};
}
+sub natatime : method {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub {
+ my ( $instance, $n, $f ) = @_;
+ my $it = List::MoreUtils::natatime($n, @{ $reader->($instance) });
+ if ($f) {
+ while (my @vals = $it->()) {
+ $f->(@vals);
+ }
+ }
+ $it;
+ };
+}
+
1;
__END__
=item B<first( sub { ... } )>
-This method returns the first item matching item in the array. The matching is
-done with a subroutine reference you pass to this method. The reference will
-be called against each element in the array until one matches or all elements
-have been checked.
+This method returns the first item matching item in the array, just like
+L<List::Util>'s C<first> function. The matching is done with a subroutine
+reference you pass to this method. The reference will be called against each
+element in the array until one matches or all elements have been checked.
my $found = $stuff->find_option( sub { /^b/ } );
print "$found\n"; # prints "bar"
my @mod_options = $stuff->map_options( sub { $_ . "-tag" } );
print "@mod_options\n"; # prints "foo-tag bar-tag baz-tag boo-tag"
+=item B<reduce( sub { ... } )>
+
+This method condenses an array into a single value, by passing a function the
+value so far and the next value in the array, just like L<List::Util>'s
+C<reduce> function. The reducing is done with a subroutine reference you pass
+to this method.
+
+ my $found = $stuff->reduce_options( sub { $_[0] . $_[1] } );
+ print "$found\n"; # prints "foobarbazboo"
+
=item B<sort( sub { ... } )>
Returns a the array in sorted order.
Perl's core C<sort> function). However, instead of using C<$a> and C<$b>, you
will need to use C<$_[0]> and C<$_[1]> instead.
+=item B<shuffle>
+
+Returns the array, with indices in random order, like C<shuffle> from
+L<List::Util>.
+
+=item B<uniq>
+
+Returns the array, with all duplicate elements removed, like C<uniq> from
+L<List::MoreUtils>.
+
=item B<join($str)>
Joins every element of the array using the separator given as argument, just
If passed one argument, it returns the value at the specified index. If
passed two arguments, it sets the value of the specified index.
+=item B<natatime($n, $code)>
+
+This method returns an iterator which, on each call, returns C<$n> more items
+from the array, in order, like C<natatime> from L<List::MoreUtils>. A coderef
+can optionally be provided; it will be called on each group of C<$n> elements
+in the array.
+
=back
=head1 METHODS
use strict;
use warnings;
-use Test::More tests => 31;
+use Test::More tests => 43;
use Test::Exception;
use Test::Moose 'does_ok';
my $sort;
my $less;
my $up;
+my $prod;
{
package Stuff;
use Moose;
'join_options' => 'join',
'get_option_at' => 'get',
'sorted_options' => 'sort',
+ 'randomized_options' => 'shuffle',
+ 'unique_options' => 'uniq',
'less_than_five' => [ grep => ($less = sub { $_ < 5 }) ],
'up_by_one' => [ map => ($up = sub { $_ + 1 }) ],
+ 'pairwise_options' => [ natatime => 2 ],
'dashify' => [ join => '-' ],
'descending' => [ sort => ($sort = sub { $_[1] <=> $_[0] }) ],
+ 'product' => [ reduce => ($prod = sub { $_[0] * $_[1] }) ],
},
);
join_options
get_option_at
sorted_options
+ randomized_options
+ unique_options
+ less_than_five
+ up_by_one
+ pairwise_options
+ dashify
+ descending
+ product
];
is_deeply( $stuff->_options, [ 1 .. 10 ], '... got options' );
qr/Argument must be a code reference/,
'error when sort receives a non-coderef argument';
+is_deeply( [ sort { $a <=> $b } $stuff->randomized_options ], [ 1 .. 10 ] );
+
+my @pairs;
+$stuff->pairwise_options(sub { push @pairs, [@_] });
+is_deeply( \@pairs, [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ], [ 7, 8 ], [ 9, 10 ] ] );
+
# test the currying
is_deeply( [ $stuff->less_than_five() ], [ 1 .. 4 ] );
is_deeply( [ $stuff->descending ], [ reverse 1 .. 10 ] );
+is( $stuff->product, 3628800 );
+
+my $other_stuff = Stuff->new( options => [ 1, 1, 2, 3, 5 ] );
+is_deeply( [ $other_stuff->unique_options ], [1, 2, 3, 5] );
+
## test the meta
my $options = $stuff->meta->get_attribute('_options');
'join_options' => 'join',
'get_option_at' => 'get',
'sorted_options' => 'sort',
+ 'randomized_options' => 'shuffle',
+ 'unique_options' => 'uniq',
'less_than_five' => [ grep => $less ],
'up_by_one' => [ map => $up ],
+ 'pairwise_options' => [ natatime => 2 ],
'dashify' => [ join => '-' ],
'descending' => [ sort => $sort ],
+ 'product' => [ reduce => $prod ],
},
'... got the right handles mapping'
);
projects / gitmo/Moose.git / commitdiff