File Coverage

blib/lib/List/OrderBy.pm

Criterion	Covered	Total	%
statement	53	72	73.6
branch	1	2	50.0
condition	3	6	50.0
subroutine	11	25	44.0
pod	8	8	100.0
total	76	113	67.2

package List::OrderBy;
use strict;
use warnings;
use Exporter;

use vars qw{ $VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS };

BEGIN {
  @ISA = qw(Exporter);
  %EXPORT_TAGS = ( 'all' => [ qw(
    order_by              then_by
    order_cmp_by          then_cmp_by
    order_by_desc         then_by_desc
    order_cmp_by_desc     then_cmp_by_desc
  ) ] );

  @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
  @EXPORT = @EXPORT_OK;
  $VERSION = '0.2';
};

sub order_by(&;@) {
  List::OrderBy::Container->new(sub { $_[0] <=> $_[1] }, @_)->get();
}

sub order_by_desc(&;@) {
  List::OrderBy::Container->new(sub { $_[1] <=> $_[0] }, @_)->get();
}

sub order_cmp_by_desc(&;@) {
  List::OrderBy::Container->new(sub { $_[1] cmp $_[0] }, @_)->get();
}

sub order_cmp_by(&;@) {
  List::OrderBy::Container->new(sub { $_[0] cmp $_[1] }, @_)->get();
}

sub then_by(&;@) {
  List::OrderBy::Container->new(sub { $_[0] <=> $_[1] }, @_)
}

sub then_by_desc(&;@) {
  List::OrderBy::Container->new(sub { $_[1] <=> $_[0] }, @_)
}

sub then_cmp_by(&;@) {
  List::OrderBy::Container->new(sub { $_[0] cmp $_[1] }, @_)
}

sub then_cmp_by_desc(&;@) {
  List::OrderBy::Container->new(sub { $_[1] cmp $_[0] }, @_)
}

package List::OrderBy::Container;
use strict;
use warnings;

sub new {
  my $class = shift;
  my $key_comparer = shift;
  my $key_extractor = shift;
  my @list = @_;
  my $self = bless { }, $class;

  # Chained then_by calls are merged into a single object
  if (@list and UNIVERSAL::isa($list[0], __PACKAGE__)) {

    # Copy reference to the list and the existing key extractors
    $self->{key_extractors} = [ @{ $list[0]->{key_extractors} } ];
    $self->{key_comparers}  = [ @{ $list[0]->{key_comparers} } ];
    $self->{list}           = $list[0]->{list};

  } else {
    $self->{list} = \@list;
  }

  # A sequence `order_by { ... } then_by { ... }` is evaluated from
  # the right to the left, and to make the first element the first
  # extractor to be applied, elements are unshifted into the list.

  unshift @{ $self->{key_extractors} }, $key_extractor;
  unshift @{ $self->{key_comparers} }, $key_comparer;

  $self;
}

sub get {
  my $merged = shift;

  # Extract all keys
  my @keys = map {
    my $code = $_;

    # When a sub is used as key extractor instead of a code block,
    # authors would expect the data passed in as argument, so this
    # does both, pass through $_ and pass through the parameter.

    [ map { scalar $code->($_); } @{ $merged->{list} } ]

  } @{ $merged->{key_extractors} };

  my @sorted_indices = sort {
    my $compare = 0;
    for (my $ix = 0; !$compare and $ix <= $#keys; ++$ix) {
      $compare = $merged->{key_comparers}[$ix]
        ->($keys[$ix]->[$a], $keys[$ix]->[$b]);
    }
    $compare;
  } 0 .. $#{ $merged->{list} };

  return map { $merged->{list}[$_] } @sorted_indices;
}

1;

__END__