From: Jesse Luehrs Date: Tue, 18 Aug 2009 07:58:24 +0000 (-0500) Subject: add a few helpful List::(More)?Utils? funcs to the native Array trait X-Git-Tag: 0.89_02~52 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7960bcc08093a50fa12b754a0b4b371996bd946f;p=gitmo%2FMoose.git add a few helpful List::(More)?Utils? funcs to the native Array trait --- diff --git a/lib/Moose/Manual/Delta.pod b/lib/Moose/Manual/Delta.pod index abcbd8b..733a3eb 100644 --- a/lib/Moose/Manual/Delta.pod +++ b/lib/Moose/Manual/Delta.pod @@ -62,6 +62,10 @@ Helpers that take a coderef of two or more arguments remain using the argument list (there are technical limitations to using C<$a> and C<$b> like C does). +=item Several new helpers from L and L were added + +In particular, we now have C, C, C, and C. + =back See L for the new documentation. diff --git a/lib/Moose/Meta/Attribute/Native/MethodProvider/Array.pm b/lib/Moose/Meta/Attribute/Native/MethodProvider/Array.pm index ebc887d..63e1b55 100644 --- a/lib/Moose/Meta/Attribute/Native/MethodProvider/Array.pm +++ b/lib/Moose/Meta/Attribute/Native/MethodProvider/Array.pm @@ -1,6 +1,9 @@ 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'; @@ -23,11 +26,7 @@ sub first : method { 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) }); }; } @@ -39,6 +38,15 @@ sub map : method { }; } +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 { @@ -62,6 +70,14 @@ sub sort : method { }; } +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 { @@ -70,6 +86,14 @@ sub grep : method { }; } +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 { @@ -317,6 +341,20 @@ sub sort_in_place : method { }; } +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__ diff --git a/lib/Moose/Meta/Attribute/Native/Trait/Array.pm b/lib/Moose/Meta/Attribute/Native/Trait/Array.pm index 139fccf..ed75ce6 100644 --- a/lib/Moose/Meta/Attribute/Native/Trait/Array.pm +++ b/lib/Moose/Meta/Attribute/Native/Trait/Array.pm @@ -114,10 +114,10 @@ These methods are all equivalent to the Perl core functions of the same name. =item B -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's C 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" @@ -140,6 +140,16 @@ implements the transformation. my @mod_options = $stuff->map_options( sub { $_ . "-tag" } ); print "@mod_options\n"; # prints "foo-tag bar-tag baz-tag boo-tag" +=item B + +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's +C 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 Returns a the array in sorted order. @@ -163,6 +173,16 @@ You can provide an optional subroutine reference to sort with (as you can with Perl's core C function). However, instead of using C<$a> and C<$b>, you will need to use C<$_[0]> and C<$_[1]> instead. +=item B + +Returns the array, with indices in random order, like C from +L. + +=item B + +Returns the array, with all duplicate elements removed, like C from +L. + =item B Joins every element of the array using the separator given as argument, just @@ -193,6 +213,13 @@ This method provides a get/set accessor for the array, based on array indexes. 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 + +This method returns an iterator which, on each call, returns C<$n> more items +from the array, in order, like C from L. A coderef +can optionally be provided; it will be called on each group of C<$n> elements +in the array. + =back =head1 METHODS diff --git a/t/070_native_traits/205_trait_list.t b/t/070_native_traits/205_trait_list.t index 7ec29a0..8e6a37a 100644 --- a/t/070_native_traits/205_trait_list.t +++ b/t/070_native_traits/205_trait_list.t @@ -3,13 +3,14 @@ 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; @@ -30,10 +31,14 @@ my $up; '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] }) ], }, ); @@ -53,6 +58,14 @@ can_ok( $stuff, $_ ) for qw[ 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' ); @@ -95,6 +108,12 @@ throws_ok { $stuff->sorted_options('foo') } 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 ] ); @@ -104,6 +123,11 @@ is( $stuff->dashify, '1-2-3-4-5-6-7-8-9-10' ); 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'); @@ -121,10 +145,14 @@ is_deeply( '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' );