File Coverage

blib/lib/Array/GroupBy.pm

Criterion	Covered	Total	%
statement	51	51	100.0
branch	17	18	94.4
condition	9	10	90.0
subroutine	15	15	100.0
pod	3	3	100.0
total	95	97	97.9

package Array::GroupBy;

use warnings;
use strict;

use 5.008_008;

use List::Util qw(max);

use version; our $VERSION = qv('0.0.4');

use base qw( Exporter );
our @EXPORT = qw( igroup_by );
our @EXPORT_OK = qw( igroup_by str_row_equal num_row_equal);

# Copyright Stanford University. March 8th, 2012
# All rights reserved.
# Author: Sam Brain

use Carp;
use Params::Validate qw(:all);

########################################
sub igroup_by {
  my %opts = validate(@_, {data    => { type => ARRAYREF                },
                           compare => { type => CODEREF                 },
                           args    => { type => ARRAYREF, optional => 1 },
                          }
  );

  my ($data, $compare, $args) = @opts{qw(data compare args)};

  croak "The array passed to igroup_by( data => ... ) is empty, called"
    unless @$data;

  my $previous_line = $data->[0];

  my $i = 1;  # index into @$data

  return sub {
    my @result;
    my $line;

    return unless $previous_line;

    push @result, $previous_line;

    while ($line = $data->[$i++]) {
      last
        unless $compare->($previous_line, $line, $args);

      push @result, $line;
    }
    # line was different from previous, or end-of-data
    $previous_line = $line;

    return \@result;
  }
}

########################################
sub str_row_equal { return _row_equal( sub { $_[0] eq $_[1] }, @_ ) }
sub num_row_equal { return _row_equal( sub { $_[0] == $_[1] }, @_ ) }

########################################
sub _row_equal {
  my ($is_equal, $first, $second, $slice) = @_;

  return 0 if @$first != @$second;

  $slice = [ 0 .. $#$first] unless $slice and @$slice;

  #print "_row_equal(): slice @$slice, ", max(@$slice), ", ", $#$first, " \n";

  # slice out of bounds
  return 0 if max(@$slice) > $#$first;

  #print "_row_equal(): slice @$slice\n";

  foreach (@$slice) {
    # both undef
    next unless defined $first->[$_] or defined $second->[$_];

    # one defined, one not
    return 0 if defined $first->[$_] xor defined $second->[$_];

    #print "first ", $first->[$_], " second ", $second->[$_], "\n";

    return 0 unless $is_equal->($first->[$_], $second->[$_]);
  }

  return 1;
}

1;

__END__