File Coverage

inc/List/MoreUtils/PP.pm

Criterion	Covered	Total	%
statement	23	438	5.2
branch	0	178	0.0
condition	0	56	0.0
subroutine	8	72	11.1
pod	0	60	0.0
total	31	804	3.8

#line 1
package List::MoreUtils::PP;

use 5.008_001;
use strict;
use warnings;

our $VERSION = '0.428';

#line 20

sub any (&@)
{
    my $f = shift;
    foreach (@_)
    {
        return 1 if $f->();
    }
    return 0;
}

sub all (&@)
{
    my $f = shift;
    foreach (@_)
    {
        return 0 unless $f->();
    }
    return 1;
}

sub none (&@)
{
    my $f = shift;
    foreach (@_)
    {
        return 0 if $f->();
    }
    return 1;
}

sub notall (&@)
{
    my $f = shift;
    foreach (@_)
    {
        return 1 unless $f->();
    }
    return 0;
}

sub one (&@)
{
    my $f     = shift;
    my $found = 0;
    foreach (@_)
    {
        $f->() and $found++ and return 0;
    }
    $found;
}

sub any_u (&@)
{
    my $f = shift;
    return if !@_;
    $f->() and return 1 foreach (@_);
    return 0;
}

sub all_u (&@)
{
    my $f = shift;
    return if !@_;
    $f->() or return 0 foreach (@_);
    return 1;
}

sub none_u (&@)
{
    my $f = shift;
    return if !@_;
    $f->() and return 0 foreach (@_);
    return 1;
}

sub notall_u (&@)
{
    my $f = shift;
    return if !@_;
    $f->() or return 1 foreach (@_);
    return 0;
}

sub one_u (&@)
{
    my $f = shift;
    return if !@_;
    my $found = 0;
    foreach (@_)
    {
        $f->() and $found++ and return 0;
    }
    $found;
}

sub reduce_u(&@)
{
    my $code = shift;

    # Localise $a, $b
    my ($caller_a, $caller_b) = do
    {
        my $pkg = caller();
        no strict 'refs';
        \*{$pkg . '::a'}, \*{$pkg . '::b'};
    };

    local (*$caller_a, *$caller_b);
    *$caller_a = \();
    for (0 .. $#_)
    {
        *$caller_b = \$_[$_];
        *$caller_a = \($code->());
    }

    ${*$caller_a};
}

sub reduce_0(&@)
{
    my $code = shift;

    # Localise $a, $b
    my ($caller_a, $caller_b) = do
    {
        my $pkg = caller();
        no strict 'refs';
        \*{$pkg . '::a'}, \*{$pkg . '::b'};
    };

    local (*$caller_a, *$caller_b);
    *$caller_a = \0;
    for (0 .. $#_)
    {
        *$caller_b = \$_[$_];
        *$caller_a = \($code->());
    }

    ${*$caller_a};
}

sub reduce_1(&@)
{
    my $code = shift;

    # Localise $a, $b
    my ($caller_a, $caller_b) = do
    {
        my $pkg = caller();
        no strict 'refs';
        \*{$pkg . '::a'}, \*{$pkg . '::b'};
    };

    local (*$caller_a, *$caller_b);
    *$caller_a = \1;
    for (0 .. $#_)
    {
        *$caller_b = \$_[$_];
        *$caller_a = \($code->());
    }

    ${*$caller_a};
}

sub true (&@)
{
    my $f     = shift;
    my $count = 0;
    $f->() and ++$count foreach (@_);
    return $count;
}

sub false (&@)
{
    my $f     = shift;
    my $count = 0;
    $f->() or ++$count foreach (@_);
    return $count;
}

sub firstidx (&@)
{
    my $f = shift;
    foreach my $i (0 .. $#_)
    {
        local *_ = \$_[$i];
        return $i if $f->();
    }
    return -1;
}

sub firstval (&@)
{
    my $test = shift;
    foreach (@_)
    {
        return $_ if $test->();
    }
    return undef;
}

sub firstres (&@)
{
    my $test = shift;
    foreach (@_)
    {
        my $testval = $test->();
        $testval and return $testval;
    }
    return undef;
}

sub onlyidx (&@)
{
    my $f = shift;
    my $found;
    foreach my $i (0 .. $#_)
    {
        local *_ = \$_[$i];
        $f->() or next;
        defined $found and return -1;
        $found = $i;
    }
    return defined $found ? $found : -1;
}

sub onlyval (&@)
{
    my $test   = shift;
    my $result = undef;
    my $found  = 0;
    foreach (@_)
    {
        $test->() or next;
        $result = $_;
        $found++ and return undef;
    }
    return $result;
}

sub onlyres (&@)
{
    my $test   = shift;
    my $result = undef;
    my $found  = 0;
    foreach (@_)
    {
        my $rv = $test->() or next;
        $result = $rv;
        $found++ and return undef;
    }
    return $found ? $result : undef;
}

sub lastidx (&@)
{
    my $f = shift;
    foreach my $i (reverse 0 .. $#_)
    {
        local *_ = \$_[$i];
        return $i if $f->();
    }
    return -1;
}

sub lastval (&@)
{
    my $test = shift;
    my $ix;
    for ($ix = $#_; $ix >= 0; $ix--)
    {
        local *_ = \$_[$ix];
        my $testval = $test->();

        # Simulate $_ as alias
        $_[$ix] = $_;
        return $_ if $testval;
    }
    return undef;
}

sub lastres (&@)
{
    my $test = shift;
    my $ix;
    for ($ix = $#_; $ix >= 0; $ix--)
    {
        local *_ = \$_[$ix];
        my $testval = $test->();

        # Simulate $_ as alias
        $_[$ix] = $_;
        return $testval if $testval;
    }
    return undef;
}

sub insert_after (&$\@)
{
    my ($f, $val, $list) = @_;
    my $c = &firstidx($f, @$list);
    @$list = (@{$list}[0 .. $c], $val, @{$list}[$c + 1 .. $#$list],) and return 1 if $c != -1;
    return 0;
}

sub insert_after_string ($$\@)
{
    my ($string, $val, $list) = @_;
    my $c = firstidx { defined $_ and $string eq $_ } @$list;
    @$list = (@{$list}[0 .. $c], $val, @{$list}[$c + 1 .. $#$list],) and return 1 if $c != -1;
    return 0;
}

sub apply (&@)
{
    my $action = shift;
    &$action foreach my @values = @_;
    wantarray ? @values : $values[-1];
}

sub after (&@)
{
    my $test = shift;
    my $started;
    my $lag;
    grep $started ||= do
    {
        my $x = $lag;
        $lag = $test->();
        $x;
    }, @_;
}

sub after_incl (&@)
{
    my $test = shift;
    my $started;
    grep $started ||= $test->(), @_;
}

sub before (&@)
{
    my $test = shift;
    my $more = 1;
    grep $more &&= !$test->(), @_;
}

sub before_incl (&@)
{
    my $test = shift;
    my $more = 1;
    my $lag  = 1;
    grep $more &&= do
    {
        my $x = $lag;
        $lag = !$test->();
        $x;
    }, @_;
}

sub indexes (&@)
{
    my $test = shift;
    grep {
        local *_ = \$_[$_];
        $test->()
    } 0 .. $#_;
}

sub pairwise (&\@\@)
{
    my $op = shift;

    # Symbols for caller's input arrays
    use vars qw{ @A @B };
    local (*A, *B) = @_;

    # Localise $a, $b
    my ($caller_a, $caller_b) = do
    {
        my $pkg = caller();
        no strict 'refs';
        \*{$pkg . '::a'}, \*{$pkg . '::b'};
    };

    # Loop iteration limit
    my $limit = $#A > $#B ? $#A : $#B;

    # This map expression is also the return value
    local (*$caller_a, *$caller_b);
    map {
        # Assign to $a, $b as refs to caller's array elements
        (*$caller_a, *$caller_b) = \($#A < $_ ? undef : $A[$_], $#B < $_ ? undef : $B[$_]);

        # Perform the transformation
        $op->();
    } 0 .. $limit;
}

sub each_array (\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@)
{
    return each_arrayref(@_);
}

sub each_arrayref
{
    my @list  = @_;    # The list of references to the arrays
    my $index = 0;     # Which one the caller will get next
    my $max   = 0;     # Number of elements in longest array

    # Get the length of the longest input array
    foreach (@list)
    {
        unless (ref $_ eq 'ARRAY')
        {
            require Carp;
            Carp::croak("each_arrayref: argument is not an array reference\n");
        }
        $max = @$_ if @$_ > $max;
    }

    # Return the iterator as a closure wrt the above variables.
    return sub {
        if (@_)
        {
            my $method = shift;
            unless ($method eq 'index')
            {
                require Carp;
                Carp::croak("each_array: unknown argument '$method' passed to iterator.");
            }

            # Return current (last fetched) index
            return undef if $index == 0 || $index > $max;
            return $index - 1;
        }

        # No more elements to return
        return if $index >= $max;
        my $i = $index++;

        # Return ith elements
        return map $_->[$i], @list;
      }
}

sub natatime ($@)
{
    my $n    = shift;
    my @list = @_;
    return sub {
        return splice @list, 0, $n;
      }
}

# "leaks" when lexically hidden in arrayify
my $flatten;
$flatten = sub {
    map { (ref $_ and ("ARRAY" eq ref $_ or overload::Method($_, '@{}'))) ? ($flatten->(@{$_})) : ($_) } @_;
};

sub arrayify
{
    map { $flatten->($_) } @_;
}

sub mesh (\@\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@)
{
    my $max = -1;
    $max < $#$_ && ($max = $#$_) foreach @_;
    map {
        my $ix = $_;
        map $_->[$ix], @_;
    } 0 .. $max;
}

sub zip6 (\@\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@)
{
    my $max = -1;
    $max < $#$_ && ($max = $#$_) foreach @_;
    map {
        my $ix = $_;
        [map $_->[$ix], @_];
    } 0 .. $max;
}

sub listcmp (\@\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@)
{
    my %ret;
    for (my $i = 0; $i < scalar @_; ++$i)
    {
        my %seen;
        my $k;
        foreach my $w (grep { defined $_ and not $seen{$k = $_}++ } @{$_[$i]})
        {
            $ret{$w} ||= [];
            push @{$ret{$w}}, $i;
        }
    }
    %ret;
}

sub uniq (@)
{
    my %seen = ();
    my $k;
    my $seen_undef;
    grep { defined $_ ? not $seen{$k = $_}++ : not $seen_undef++ } @_;
}

sub singleton (@)
{
    my %seen = ();
    my $k;
    my $seen_undef;
    grep { 1 == (defined $_ ? $seen{$k = $_} : $seen_undef) }
      grep { defined $_ ? not $seen{$k = $_}++ : not $seen_undef++ } @_;
}

sub duplicates (@)
{
    my %seen = ();
    my $k;
    my $seen_undef;
    grep { 1 < (defined $_ ? $seen{$k = $_} : $seen_undef) }
      grep { defined $_ ? not $seen{$k = $_}++ : not $seen_undef++ } @_;
}

sub frequency (@)
{
    my %seen = ();
    my $k;
    my $seen_undef;
    my %h = map { defined $_ ? ($_ => $seen{$k = $_}) : () }
      grep { defined $_ ? not $seen{$k = $_}++ : not $seen_undef++ } @_;
    wantarray or return (scalar keys %h) + ($seen_undef ? 1 : 0);
    undef $k;
    (%h, $seen_undef ? (\$k => $seen_undef) : ());
}

sub occurrences (@)
{
    my %seen = ();
    my $k;
    my $seen_undef;
    my @ret;
    foreach my $l (map { $_ } grep { defined $_ ? not $seen{$k = $_}++ : not $seen_undef++ } @_)
    {
        my $n = defined $l ? $seen{$l} : $seen_undef;
        defined $ret[$n] or $ret[$n] = [];
        push @{$ret[$n]}, $l;
    }
    @ret;
}

sub mode (@)
{
    my %seen = ();
    my ($max, $k, $seen_undef) = (1);

    foreach (@_) { defined $_ ? ($max < ++$seen{$k = $_} and ++$max) : ($max < ++$seen_undef and ++$max) }
    wantarray or return $max;

    my @ret = ($max);
    foreach my $l (grep { $seen{$_} == $max } keys %seen)
    {
        push @ret, $l;
    }
    $seen_undef and $seen_undef == $max and push @ret, undef;
    @ret;
}

sub samples ($@)
{
    my $n = shift;
    if ($n > @_)
    {
        require Carp;
        Carp::croak(sprintf("Cannot get %d samples from %d elements", $n, scalar @_));
    }

    for (my $i = @_; @_ - $i > $n;)
    {
        my $idx  = @_ - $i;
        my $swp  = $idx + int(rand(--$i));
        my $xchg = $_[$swp];
        $_[$swp] = $_[$idx];
        $_[$idx] = $xchg;
    }

    return splice @_, 0, $n;
}

sub minmax (@)
{
    return unless @_;
    my $min = my $max = $_[0];

    for (my $i = 1; $i < @_; $i += 2)
    {
        if ($_[$i - 1] <= $_[$i])
        {
            $min = $_[$i - 1] if $min > $_[$i - 1];
            $max = $_[$i]     if $max < $_[$i];
        }
        else
        {
            $min = $_[$i]     if $min > $_[$i];
            $max = $_[$i - 1] if $max < $_[$i - 1];
        }
    }

    if (@_ & 1)
    {
        my $i = $#_;
        if ($_[$i - 1] <= $_[$i])
        {
            $min = $_[$i - 1] if $min > $_[$i - 1];
            $max = $_[$i]     if $max < $_[$i];
        }
        else
        {
            $min = $_[$i]     if $min > $_[$i];
            $max = $_[$i - 1] if $max < $_[$i - 1];
        }
    }

    return ($min, $max);
}

sub minmaxstr (@)
{
    return unless @_;
    my $min = my $max = $_[0];

    for (my $i = 1; $i < @_; $i += 2)
    {
        if ($_[$i - 1] le $_[$i])
        {
            $min = $_[$i - 1] if $min gt $_[$i - 1];
            $max = $_[$i]     if $max lt $_[$i];
        }
        else
        {
            $min = $_[$i]     if $min gt $_[$i];
            $max = $_[$i - 1] if $max lt $_[$i - 1];
        }
    }

    if (@_ & 1)
    {
        my $i = $#_;
        if ($_[$i - 1] le $_[$i])
        {
            $min = $_[$i - 1] if $min gt $_[$i - 1];
            $max = $_[$i]     if $max lt $_[$i];
        }
        else
        {
            $min = $_[$i]     if $min gt $_[$i];
            $max = $_[$i - 1] if $max lt $_[$i - 1];
        }
    }

    return ($min, $max);
}

sub part (&@)
{
    my ($code, @list) = @_;
    my @parts;
    push @{$parts[$code->($_)]}, $_ foreach @list;
    return @parts;
}

sub bsearch(&@)
{
    my $code = shift;

    my $rc;
    my $i = 0;
    my $j = @_;
    do
    {
        my $k = int(($i + $j) / 2);

        $k >= @_ and return;

        local *_ = \$_[$k];
        $rc = $code->();

        $rc == 0
          and return wantarray ? $_ : 1;

        if ($rc < 0)
        {
            $i = $k + 1;
        }
        else
        {
            $j = $k - 1;
        }
    } until $i > $j;

    return;
}

sub bsearchidx(&@)
{
    my $code = shift;

    my $rc;
    my $i = 0;
    my $j = @_;
    do
    {
        my $k = int(($i + $j) / 2);

        $k >= @_ and return -1;

        local *_ = \$_[$k];
        $rc = $code->();

        $rc == 0 and return $k;

        if ($rc < 0)
        {
            $i = $k + 1;
        }
        else
        {
            $j = $k - 1;
        }
    } until $i > $j;

    return -1;
}

sub lower_bound(&@)
{
    my $code  = shift;
    my $count = @_;
    my $first = 0;
    while ($count > 0)
    {
        my $step = $count >> 1;
        my $it   = $first + $step;
        local *_ = \$_[$it];
        if ($code->() < 0)
        {
            $first = ++$it;
            $count -= $step + 1;
        }
        else
        {
            $count = $step;
        }
    }

    $first;
}

sub upper_bound(&@)
{
    my $code  = shift;
    my $count = @_;
    my $first = 0;
    while ($count > 0)
    {
        my $step = $count >> 1;
        my $it   = $first + $step;
        local *_ = \$_[$it];
        if ($code->() <= 0)
        {
            $first = ++$it;
            $count -= $step + 1;
        }
        else
        {
            $count = $step;
        }
    }

    $first;
}

sub equal_range(&@)
{
    my $lb = &lower_bound(@_);
    my $ub = &upper_bound(@_);
    ($lb, $ub);
}

sub binsert (&$\@)
{
    my $lb = &lower_bound($_[0], @{$_[2]});
    splice @{$_[2]}, $lb, 0, $_[1];
    $lb;
}

sub bremove (&\@)
{
    my $lb = &lower_bound($_[0], @{$_[1]});
    splice @{$_[1]}, $lb, 1;
}

sub qsort(&\@)
{
    require Carp;
    Carp::croak("It's insane to use a pure-perl qsort");
}

sub sort_by(&@)
{
    my ($code, @list) = @_;
    return map { $_->[0] }
      sort     { $a->[1] cmp $b->[1] }
      map { [$_, scalar($code->())] } @list;
}

sub nsort_by(&@)
{
    my ($code, @list) = @_;
    return map { $_->[0] }
      sort     { $a->[1] <=> $b->[1] }
      map { [$_, scalar($code->())] } @list;
}

sub _XScompiled { 0 }

#line 888

1;