package List::Objects::WithUtils::Role::Array;
{
$List::Objects::WithUtils::Role::Array::VERSION = '2.002004';
}
use strictures 1;
use Carp ();
use List::Util ();
use List::MoreUtils ();
use List::UtilsBy ();
use Module::Runtime ();
use Scalar::Util ();
=pod
=for Pod::Coverage ARRAY_TYPE blessed_or_pkg
=begin comment
Regarding blessed_or_pkg():
This is some nonsense to support autoboxing; if we aren't blessed, we're
autoboxed, in which case we appear to have no choice but to cheap out and
return the basic array type.
=end comment
=cut
sub ARRAY_TYPE () { 'List::Objects::WithUtils::Array' }
sub blessed_or_pkg {
Scalar::Util::blessed($_[0]) ?
$_[0] : Module::Runtime::use_module(ARRAY_TYPE)
}
sub __flatten_all {
ref $_[0] eq 'ARRAY'
|| Scalar::Util::blessed($_[0])
# 5.8 doesn't have ->DOES()
&& $_[0]->can('does')
&& $_[0]->does('List::Objects::WithUtils::Role::Array') ?
map {; __flatten_all($_) } @{ $_[0] }
: $_[0]
}
sub __flatten {
my $depth = shift;
CORE::map {
ref eq 'ARRAY'
|| Scalar::Util::blessed($_)
&& $_->can('does')
&& $_->does('List::Objects::WithUtils::Role::Array') ?
$depth > 0 ? __flatten( $depth - 1, @$_ ) : $_
: $_
} @_
}
use Role::Tiny;
sub inflated_type { 'List::Objects::WithUtils::Hash' }
sub is_mutable { 1 }
sub is_immutable { ! $_[0]->is_mutable }
sub _try_coerce {
my (undef, $type, @vals) = @_;
Carp::confess "Expected a Type::Tiny type but got $type"
unless Scalar::Util::blessed $type;
CORE::map {;
my $coerced;
$type->check($_) ? $_
: $type->assert_valid(
$type->has_coercion ? ($coerced = $type->coerce($_)) : $_
) ? $coerced
: Carp::confess "I should be unreachable!"
} @vals
}
=pod
=for Pod::Coverage TO_JSON type
=cut
sub type {
# array() has an empty ->type
}
sub new {
if (my $blessed = Scalar::Util::blessed $_[0]) {
return bless [ @_[1 .. $#_] ], $blessed
}
bless [ @_[1 .. $#_] ], $_[0]
}
sub copy {
my ($self) = @_;
blessed_or_pkg($self)->new(@$self);
}
sub inflate {
my ($self) = @_;
my $pkg = blessed_or_pkg($self);
Module::Runtime::require_module( $pkg->inflated_type );
$pkg->inflated_type->new(@$self)
}
sub unbless { [ @{ $_[0] } ] }
{ no warnings 'once'; *TO_JSON = *unbless; }
sub validated {
my ($self, $type) = @_;
blessed_or_pkg($_[0])->new(
CORE::map {; $self->_try_coerce($type, $_) } @$self
)
}
sub all { @{ $_[0] } }
sub count { CORE::scalar @{ $_[0] } }
sub end { $#{ $_[0] } }
{ no warnings 'once';
*scalar = *count;
*export = *all;
*elements = *all;
}
sub is_empty { CORE::scalar @{ $_[0] } ? 0 : 1 }
sub get { $_[0]->[ $_[1] ] }
sub set { $_[0]->[ $_[1] ] = $_[2] ; $_[0] }
sub random { $_[0]->[ rand @{ $_[0] } ] }
sub kv {
my ($self) = @_;
blessed_or_pkg($self)->new(
map {; [ $_ => $self->[$_] ] } 0 .. $#$self
)
}
sub head {
wantarray ?
(
$_[0]->[0],
blessed_or_pkg($_[0])->new( @{ $_[0] }[ 1 .. $#{$_[0]} ] )
)
: $_[0]->[0]
}
sub tail {
wantarray ?
(
$_[0]->[-1],
blessed_or_pkg($_[0])->new( @{ $_[0] }[ 0 .. ($#{$_[0]} - 1) ] )
)
: $_[0]->[-1]
}
sub pop { CORE::pop @{ $_[0] } }
sub push {
CORE::push @{ $_[0] }, @_[1 .. $#_];
$_[0]
}
sub shift { CORE::shift @{ $_[0] } }
sub unshift {
CORE::unshift @{ $_[0] }, @_[1 .. $#_];
$_[0]
}
sub clear { @{ $_[0] } = (); $_[0] }
sub delete { scalar CORE::splice @{ $_[0] }, $_[1], 1 }
sub delete_when {
my ($self, $sub) = @_;
my @removed;
my $i = @$self;
while ($i--) {
CORE::push @removed, CORE::splice @$self, $i, 1
if $sub->(local $_ = $self->[$i]);
}
blessed_or_pkg($_[0])->new(@removed)
}
sub insert {
CORE::splice @{ $_[0] }, $_[1], 0, $_[2];
$_[0]
}
sub join {
CORE::join(
( defined $_[1] ? $_[1] : ',' ),
@{ $_[0] }
)
}
sub map {
blessed_or_pkg($_[0])->new(
CORE::map {; $_[1]->($_) } @{ $_[0] }
)
}
sub mapval {
my ($self, $sub) = @_;
my @copy = @$self;
blessed_or_pkg($_[0])->new(
CORE::map {; $sub->($_); $_ } @copy
)
}
sub grep {
blessed_or_pkg($_[0])->new(
CORE::grep {; $_[1]->($_) } @{ $_[0] }
)
}
sub sort {
if (defined $_[1]) {
return blessed_or_pkg($_[0])->new(
CORE::sort {; $_[1]->($a, $b) } @{ $_[0] }
)
}
return blessed_or_pkg($_[0])->new( CORE::sort @{ $_[0] } )
}
sub reverse {
blessed_or_pkg($_[0])->new(
CORE::reverse @{ $_[0] }
)
}
sub sliced {
blessed_or_pkg($_[0])->new(
@{ $_[0] }[ @_[1 .. $#_] ]
)
}
sub splice {
blessed_or_pkg($_[0])->new(
CORE::splice @{ $_[0] }, $_[1], $_[2], @_[3 .. $#_]
)
}
sub has_any {
unless (defined $_[1]) {
return CORE::scalar @{ $_[0] }
}
&List::MoreUtils::any( $_[1], @{ $_[0] } )
}
sub first {
&List::Util::first( $_[1], @{ $_[0] } )
}
sub firstidx {
&List::MoreUtils::firstidx( $_[1], @{ $_[0] } )
}
sub mesh {
my $max_idx = -1;
for (@_) { $max_idx = $#$_ if $max_idx < $#$_ }
blessed_or_pkg($_[0])->new(
CORE::map {;
my $idx = $_; map {; $_->[$idx] } @_
} 0 .. $max_idx
)
}
sub natatime {
my $itr = List::MoreUtils::natatime($_[1], @{ $_[0] } );
if ($_[2]) {
while (my @nxt = $itr->()) { $_[2]->(@nxt) }
} else {
return $itr
}
}
sub part {
my ($self, $code) = @_;
my @parts;
CORE::push @{ $parts[ $code->($_) ] }, $_ for @$self;
my $cls = blessed_or_pkg($self);
$cls->new(
map {; $cls->new(defined $_ ? @$_ : () ) } @parts
)
}
sub bisect {
my ($self, $code) = @_;
my @parts = ( [], [] );
CORE::push @{ $parts[ $code->($_) ? 0 : 1 ] }, $_ for @$self;
my $cls = blessed_or_pkg($self);
$cls->new(
map {; $cls->new(@$_) } @parts
)
}
sub tuples {
my ($self, $size, $type) = @_;
$size = 2 unless defined $size;
Carp::confess "Expected a positive integer size but got $size"
if $size < 1;
my $itr = List::MoreUtils::natatime($size, @$self);
my @res;
while (my @nxt = $itr->()) {
if (defined $type) {
@nxt = CORE::map {; $self->_try_coerce($type, $_) }
@nxt[0 .. ($size-1)]
}
CORE::push @res, [ @nxt ];
}
blessed_or_pkg($self)->new(@res)
}
sub reduce {
List::Util::reduce { $_[1]->($a, $b) } @{ $_[0] }
}
sub items_after {
blessed_or_pkg($_[0])->new(
&List::MoreUtils::after( $_[1], @{ $_[0] } )
)
}
sub items_after_incl {
blessed_or_pkg($_[0])->new(
&List::MoreUtils::after_incl( $_[1], @{ $_[0] } )
)
}
sub items_before {
blessed_or_pkg($_[0])->new(
&List::MoreUtils::before( $_[1], @{ $_[0] } )
)
}
sub items_before_incl {
blessed_or_pkg($_[0])->new(
&List::MoreUtils::before_incl( $_[1], @{ $_[0] } )
)
}
sub shuffle {
blessed_or_pkg($_[0])->new(
List::Util::shuffle( @{ $_[0] } )
)
}
sub uniq {
blessed_or_pkg($_[0])->new(
List::MoreUtils::uniq( @{ $_[0] } )
)
}
sub sort_by {
blessed_or_pkg($_[0])->new(
&List::UtilsBy::sort_by( $_[1], @{ $_[0] } )
)
}
sub nsort_by {
blessed_or_pkg($_[0])->new(
&List::UtilsBy::nsort_by( $_[1], @{ $_[0] } )
)
}
sub uniq_by {
blessed_or_pkg($_[0])->new(
&List::UtilsBy::uniq_by( $_[1], @{ $_[0] } )
)
}
sub flatten_all {
CORE::map {; __flatten_all($_) } @{ $_[0] }
}
sub flatten {
__flatten(
( defined $_[1] ? $_[1] : 0 ),
@{ $_[0] }
)
}
print
qq[<Schroedingers_hat> My sleeping pattern is cryptographically secure.\n]
unless caller;
1;
=pod
=head1 NAME
List::Objects::WithUtils::Role::Array - Array manipulation methods
=head1 SYNOPSIS
## Via List::Objects::WithUtils::Array ->
use List::Objects::WithUtils 'array';
my $array = array(qw/ a b c /);
$array->push(qw/ d e f /);
my @upper = $array->map(sub { uc })->all;
if ( $array->has_any(sub { $_ eq 'a' }) ) {
...
}
my $sum = array(1 .. 10)->reduce(sub { $_[0] + $_[1] });
# See below for full list of methods
## As a Role ->
use Role::Tiny::With;
with 'List::Objects::WithUtils::Role::Array';
=head1 DESCRIPTION
A L<Role::Tiny> role defining methods for creating and manipulating ARRAY-type
objects.
L<List::Objects::WithUtils::Array> consumes this role (along with
L<List::Objects::WithUtils::Role::Array::WithJunctions>) to provide B<array()> object
methods.
In addition to the methods documented below, these objects provide a
C<TO_JSON> method exporting a plain ARRAY-type reference for convenience when
feeding L<JSON::Tiny> or similar.
=head2 Basic array methods
=head3 new
Constructs a new ARRAY-type object.
=head3 copy
Returns a shallow clone of the current object.
=head3 count
Returns the number of elements in the array.
=head3 end
Returns the last index of the array.
=head3 is_empty
Returns boolean true if the array is empty.
=head3 is_mutable
Returns boolean true if the hash is mutable; immutable subclasses can override
to provide a negative value.
=head3 is_immutable
The opposite of L</is_mutable>. (Subclasses do not need to override so long as
L</is_mutable> returns a correct value.)
=head3 scalar
See L</count>.
=head3 inflate
my $hash = $array->inflate;
# Same as:
# my $hash = hash( $array->all )
Inflates an array-type object to a hash-type object.
Returns an L</inflated_type> object; by default this is a
L<List::Objects::WithUtils::Hash>.
Throws an exception if the array contains an odd number of elements.
=head3 inflated_type
The class name that objects are blessed into when calling L</inflate>;
subclasses can override to provide their own hash-type objects.
Defaults to L<List::Objects::WithUtils::Hash>.
=head3 unbless
Returns a plain C</ARRAY> reference (shallow clone).
=head2 Methods that manipulate the list
=head3 clear
Delete all elements from the array.
Returns the newly-emptied array object.
=head3 delete
Splices a given index out of the array.
Returns the removed value.
=head3 delete_when
$array->delete_when( sub { $_ eq 'foo' } );
Splices all items out of the array for which the given subroutine evaluates to
true.
Returns a new array object containing the deleted values (possibly none).
=head3 insert
$array->insert( $position, $value );
Inserts a value at a given position.
Returns the array object.
=head3 pop
Pops the last element off the array and returns it.
=head3 push
Pushes elements to the end of the array.
Returns the array object.
=head3 set
$array->set( $index, $value );
Takes an array element and a new value to set.
Returns the array object.
=head3 shift
Shifts the first element off the beginning of the array and returns it.
=head3 unshift
Adds elements to the beginning of the array.
Returns the array object.
=head3 splice
# 2-arg splice (remove elements):
my $spliced = $array->splice(0, 2)
# 3-arg splice (replace):
$array->splice(0, 1, 'abc');
Performs a C<splice()> on the current list and returns a new array object
consisting of the items returned from the splice.
The existing array is modified in-place.
=head3 validated
use Types::Standard -all;
my $valid = array(qw/foo bar baz/)->validated(Str);
Accepts a L<Type::Tiny> type, against which each element of the current array
will be checked before being added to a new array. Returns the new array.
If the element fails the type check but can be coerced, the coerced value will
be added to the new array.
Dies with a stack trace if the value fails type checks and can't be coerced.
(You probably want an B<array_of> object from
L<List::Objects::WithUtils::Array::Typed> instead.)
See: L<Types::Standard>, L<List::Objects::Types>
=head2 Methods that retrieve items
=head3 all
Returns all elements in the array as a plain list.
=head3 bisect
my ($true, $false) = array( 1 .. 10 )
->bisect(sub { $_ >= 5 })
->all;
my @bigger = $true->all; # ( 5 .. 10 )
my @smaller = $false->all; # ( 1 .. 4 )
Like L</part>, but creates an array-type object containing two
partitions; the first contains all items for which the subroutine evaluates to
true, the second contains the remaining items.
=head3 elements
Same as L</all>; included for consistency with similar array-type object
classes.
=head3 export
Same as L</all>; included for consistency with hash-type objects.
=head3 flatten
Flatten array objects to plain lists, possibly recursively.
C<flatten> without arguments is the same as L</all>:
my @flat = array( 1, 2, [ 3, 4 ] )->flatten;
# @flat = ( 1, 2, [ 3, 4 ] );
If a depth is specified, sub-arrays are recursively flattened until the
specified depth is reached:
my @flat = array( 1, 2, [ 3, 4 ] )->flatten(1);
# @flat = ( 1, 2, 3, 4 );
my @flat = array( 1, 2, [ 3, 4, [ 5, 6 ] ] )->flatten(1);
# @flat = ( 1, 2, 3, 4, [ 5, 6 ] );
This works with both ARRAY-type references and array objects:
my @flat = array( 1, 2, [ 3, 4, array( 5, 6 ) ] )->flatten(2);
# @flat = ( 1, 2, 3, 4, 5, 6 );
(Specifically, consumers of this role are flattened; other ARRAY-type objects
are left alone.)
See L</flatten_all> for flattening to an unlimited depth.
=head3 flatten_all
Returns a plain list consisting of all sub-arrays recursively
flattened. Also see L</flatten>.
=head3 get
Returns the array element corresponding to a specified index.
=head3 head
my ($first, $rest) = $array->head;
In list context, returns the first element of the list, and a new array-type
object containing the remaining list. The original object's list is untouched.
In scalar context, returns just the first element of the array:
my $first = $array->head;
=head3 tail
Similar to L</head>, but returns either the last element and a new array-type
object containing the remaining list (in list context), or just the last
element of the list (in scalar context).
=head3 kv
Returns an array-type object containing key/value pairs as (unblessed) ARRAYs;
this is much like L<List::Objects::WithUtils::Role::Hash/"kv">, except the
array index is the key.
=head3 join
my $str = $array->join(' ');
Joins the array's elements and returns the joined string.
Defaults to ',' if no delimiter is specified.
=head3 mesh
my $meshed = array(qw/ a b c /)->mesh(
array( 1 .. 3 )
);
$meshed->all; # 'a', 1, 'b', 2, 'c', 3
Takes array references or objects and returns a new array object consisting of
one element from each array, in turn, until all arrays have been traversed
fully.
You can mix and match references and objects freely:
my $meshed = array(qw/ a b c /)->mesh(
array( 1 .. 3 ),
[ qw/ foo bar baz / ],
);
=head3 part
my $parts = array( 1 .. 8 )->part(sub { $i++ % 2 });
# Returns array objects:
$parts->get(0)->all; # 1, 3, 5, 7
$parts->get(1)->all; # 2, 4, 6, 8
Takes a subroutine that indicates into which partition each value should be
placed.
Returns an array-type object containing partitions represented as array-type
objects, as seen above.
Skipped partitions are empty array objects:
my $parts = array(qw/ foo bar /)->part(sub { 1 });
$parts->get(0)->is_empty; # true
$parts->get(1)->is_empty; # false
The subroutine is passed the value we are operating on, or you can use the
topicalizer C<$_>:
array(qw/foo bar baz 1 2 3/)
->part(sub { m/^[0-9]+$/ ? 0 : 1 })
->get(1)
->all; # 'foo', 'bar', 'baz'
=head3 random
Returns a random element from the array.
=head3 reverse
Returns a new array object consisting of the reversed list of elements.
=head3 shuffle
my $shuffled = $array->shuffle;
Returns a new array object containing the shuffled list.
=head3 sliced
my $slice = $array->sliced(1, 3, 5);
Returns a new array object consisting of the elements retrived
from the specified indexes.
=head3 tuples
my $tuples = array(1 .. 7)->tuples(2);
# Returns:
# array(
# [ 1, 2 ],
# [ 3, 4 ],
# [ 5, 6 ],
# [ 7 ],
# )
Simple sugar for L</natatime>; returns a new array object consisting of tuples
(unblessed ARRAY references) of the specified size (defaults to 2).
C<tuples> accepts L<Type::Tiny> types as an optional second parameter; if
specified, items in tuples are checked against the type and a coercion is
attempted if the initial type-check fails:
use Types::Standard -all;
my $tuples = array(1 .. 7)->tuples(2 => Int);
A stack-trace is thrown if a value in a tuple cannot be made to validate.
See: L<Types::Standard>, L<List::Objects::Types>
=head2 Methods that find items
=head3 grep
my $matched = $array->grep(sub { $_[0] =~ /foo/ });
Returns a new array object consisting of the list of elements for which the
given subroutine evaluated to true. C<$_[0]> is the element being operated
on; you can also use the topicalizer C<$_>.
=head3 first
my $arr = array( qw/ ab bc bd de / );
my $first = $arr->first(sub { /^b/ }); ## 'bc'
Returns the first element of the list for which the given sub evaluates to
true. C<$_> is set to each element, in turn, until a match is found (or we run
out of possibles).
=head3 firstidx
Like L</first>, but return the index of the first successful match.
=head3 has_any
if ( $array->has_any(sub { $_ eq 'foo' }) ) {
...
}
If passed no arguments, returns the same thing as L</count>.
If passed a sub, returns boolean true if the sub is true for any element
of the array; see L<List::MoreUtils/"any">.
C<$_> is set to the element being operated upon.
=head3 items_after
my $after = array( 1 .. 10 )->items_after(sub { $_ == 5 });
## $after contains [ 6, 7, 8, 9, 10 ]
Returns a new array object consisting of the elements of the original list
that occur after the first position for which the given sub evaluates to true.
=head3 items_after_incl
Like L</items_after>, but include the item that evaluated to true.
=head3 items_before
The opposite of L</items_after>.
=head3 items_before_incl
The opposite of L</items_after_incl>.
=head2 Methods that iterate the list
=head3 map
my $lowercased = $array->map(sub { lc });
# Same as:
my $lowercased = $array->map(sub { lc $_[0] });
Evaluates a given subroutine for each element of the array, and returns a new
array object. C<$_[0]> is the element being operated on; you can also use
the topicalizer C<$_>.
Also see L</mapval>.
=head3 mapval
my $orig = array(1, 2, 3);
my $incr = $orig->mapval(sub { ++$_ });
$incr->all; # (2, 3, 4)
$orig->all; # Still untouched
An alternative to L</map>. C<$_> is a copy, rather than an alias to the
current element, and the result is retrieved from the altered C<$_> rather
than the return value of the block.
This feature is borrowed from L<Data::Munge> by Lukas Mai (CPAN: MAUKE).
=head3 natatime
my $iter = array( 1 .. 7 )->natatime(3);
$iter->(); ## ( 1, 2, 3 )
$iter->(); ## ( 4, 5, 6 )
$iter->(); ## ( 7 )
array( 1 .. 7 )->natatime(3, sub { my @vals = @_; ... });
Returns an iterator that, when called, produces a list containing the next
'n' items.
If given a coderef as a second argument, it will be called against each
bundled group.
=head3 reduce
my $sum = array(1,2,3)->reduce(sub { $_[0] + $_[1] });
Reduces the array by calling the given subroutine for each element of the
list. See L<List::Util/"reduce">.
=head2 Methods that sort the list
=head3 sort
my $sorted = $array->sort(sub { $_[0] cmp $_[1] });
Returns a new array object consisting of the list sorted by the given
subroutine. C<$_[0]> and C<$_[1]> are equivalent to C<$a> and C<$b> in a
normal sort() call.
=head3 sort_by
my $array = array(
{ id => 'a' },
{ id => 'c' },
{ id => 'b' },
);
my $sorted = $array->sort_by(sub { $_->{id} });
Returns a new array object consisting of the list of elements sorted via a
stringy comparison using the given sub.
See L<List::UtilsBy>.
=head3 nsort_by
Like L</sort_by>, but using numerical comparison.
=head3 uniq
my $unique = $array->uniq;
Returns a new array object containing only unique elements from the original
array.
=head3 uniq_by
my $array = array(
{ id => 'a' },
{ id => 'a' },
{ id => 'b' },
);
my $unique = $array->uniq_by(sub { $_->{id} });
Returns a new array object consisting of the list of elements for which the
given sub returns unique values.
=head1 SEE ALSO
L<List::Objects::WithUtils>
L<List::Objects::WithUtils::Array>
L<List::Objects::WithUtils::Role::Array::WithJunctions>
L<List::Objects::WithUtils::Array::Immutable>
L<List::Objects::WithUtils::Array::Typed>
L<Data::Perl>
L<List::Util>
L<List::MoreUtils>
L<List::UtilsBy>
=head1 AUTHOR
Jon Portnoy <avenj@cobaltirc.org>
Portions of this code are derived from L<Data::Perl> by Matthew Phillips
(CPAN: MATTP), haarg et al
Licensed under the same terms as Perl.
=cut