File Coverage

blib/lib/Sort/ArrayOfArrays.pm

Criterion	Covered	Total	%
statement	75	104	72.1
branch	32	72	44.4
condition	14	38	36.8
subroutine	7	7	100.0
pod	0	4	0.0
total	128	225	56.8

#!/usr/bin/perl -w

package Sort::ArrayOfArrays;

use strict;
use Exporter;
use vars qw(@ISA @EXPORT_OK $VERSION);
@ISA = qw(Exporter);
@EXPORT_OK = qw(sort_it);
$VERSION = '1.00';

sub new {
  my $type  = shift;
  my @PASSED_ARGS = (ref $_[0] eq 'HASH') ? %{$_[0]} : @_;
  my @DEFAULT_ARGS = (
    header_row  => 0,
    results     => [],
    sort_column => '',
    sort_code   => [],
  );
  my %ARGS = (@DEFAULT_ARGS, @PASSED_ARGS);
  my $self = bless \%ARGS, $type;
  return $self;
}

sub sort_it {
  my $self = shift;

  unless(ref $self eq __PACKAGE__) {
    $self = __PACKAGE__->new({
      results     => $self,
      sort_column => $_[0],
      sort_code   => $_[1],
      header_row  => $_[2],
    });
  }

  die "\$self->{results} is required" unless($self->{results});
  die "\$self->{results} needs to be an array of arrays" unless(ref $self->{results} eq 'ARRAY' && $self->{results}->[0] && ref $self->{results}->[0] eq 'ARRAY');
  if($self->{header_row}) {
    $self->{zero_row} = shift @{$self->{results}};
  }

  $self->{rows} = (@{$self->{results}} - 1);

  $self->make_sort_code_ref;

  my $sort_method = $self->{sort_code_ref};
  my @temp = (0 .. $self->{rows});
  @temp = sort $sort_method @temp;

  my $return = [];

  for(my $i=0;$i<@temp;$i++) {
    $return->[$i] = $self->{results}->[$temp[$i]];
  }

  if($self->{header_row}) {
    unshift @{$return}, $self->{zero_row};
    delete $self->{zero_row};
  }
  $self->{results} = $return;
  return $return;
}

sub make_sort_code_text {
  my $self = shift;
  return if($self->{sort_code_text});

  my $total_sorts = 0;
  foreach my $this_sort_column (split /\s*,\s*/, $self->{sort_column}) {
    $total_sorts++;
    my $col = abs($this_sort_column);
    if($self->{sort_code} && ref $self->{sort_code}) {
      if(ref $self->{sort_code} eq 'HASH' && $self->{sort_code}->{$col}) {
        if(ref $self->{sort_code}->{$col}) {
          die "any ref for \$self->{sort_code}->{$col} needs to be an CODE ref" unless(ref $self->{sort_code}->{$col} eq 'CODE');
          $self->{sort_code_ref} = $self->{sort_code}->{$col};
          return;
        }
      } elsif(ref $self->{sort_code} eq 'ARRAY' && $self->{sort_code}->[$col]) {
        if(ref $self->{sort_code}->[$col]) {
          die "any ref for \$self->{sort_code}->[$col] needs to be an CODE ref" unless(ref $self->{sort_code}->[$col] eq 'CODE');
          $self->{sort_code_ref} = $self->{sort_code}->[$col];
          return;
        }
      }
    }
  }

  $self->{sort_code_text} = "sub {\n";#"}"
  my $this_sort = 0;
  foreach my $this_sort_column (split /\s*,\s*/, $self->{sort_column}) {
    $this_sort++;
    my $this_sort_method;
    if($self->{sort_code} && ref $self->{sort_code}) {
      if(ref $self->{sort_code} eq 'HASH' && $self->{sort_code}->{$this_sort_column}) {
        $this_sort_method = $self->{sort_code}->{$this_sort_column};
      } elsif(ref $self->{sort_code} eq 'ARRAY' && $self->{sort_code}->[$this_sort_column]) {
        $this_sort_method = $self->{sort_code}->[$this_sort_column];
      }
    }
    my $this_toggle = $this_sort_column =~ s/^\-(\d+)$/$1/;

    unless($this_sort_method) {
      $this_sort_method = 'aa';
      for(my $i=0;$i<=$self->{rows};$i++) {
        if($self->{results}->[$i]->[$this_sort_column] =~ /[^0-9.\-+ ]/) {
          last;
        } elsif($self->{results}->[$i]->[$this_sort_column] =~ /^[0-9.\-+]+$/) {
          next if($self->{results}->[$i]->[$this_sort_column] =~ /^\.+$/);
          $this_sort_method = 'na';
          last;
        }
      }
    }

    if($total_sorts == $this_sort) {
      if($this_toggle && $this_sort_method =~ /^.a$/) {
        $this_sort_method =~ s/^(.)a$/$1d/i;
      } elsif($this_toggle && $this_sort_method =~ /^.d$/) {
        $this_sort_method =~ s/^(.)d$/$1a/i;
      }
    }

    # I just change stuff of type link to stuff of type regex, with the regex below
    if ($this_sort_method =~ s/^l(.)$/r$1/i) {
      die "need regex for sort_method on column $this_sort_column" unless(exists $self->{sort_method_regex}->{$this_sort_column});
      $self->{sort_method_regex}->{$this_sort_column} = qr@]+?>(.+?)@i;
    }

    my $symbol;
    my $special_sort_method = 0;
    if($this_sort_method =~ /^a.$/i) {
      $symbol = 'cmp';
    } elsif ($this_sort_method =~ /^n.$/i) {
      $symbol = '<=>';
    } elsif ($this_sort_method =~ /^t.$/i) {
      $special_sort_method = 1;
    } elsif ($this_sort_method =~ /^r.$/i) {
      die "need regex for sort_method on column $this_sort_column" unless($self->{sort_method_regex}->{$this_sort_column});
      $symbol = $self->{sort_method_symbol}->{$this_sort_column} || 'cmp';
      $self->{sort_code_text} .= <
  my (\$_a) = \$self->{results}->[\$a]->[$this_sort_column] =~ /$self->{sort_method_regex}->{$this_sort_column}/;
  my (\$_b) = \$self->{results}->[\$b]->[$this_sort_column] =~ /$self->{sort_method_regex}->{$this_sort_column}/;
SORT_METHOD

      if($self->{sort_code}->[$this_sort_column] =~ /^.d$/i) {
        $self->{sort_code_text} = "{\n  $self->{sort_code_text}\n  \$_b $symbol \$_a\n}";
      } else {
        $self->{sort_code_text} = "{\n  $self->{sort_code_text}\n  \$_a $symbol \$_b\n}";
      }
      $special_sort_method = 1;
    } else {
      die "unknown sort method $this_sort_method";
    }

    if(!$special_sort_method && $this_sort_method =~ /^.a$/i) {
      $self->{sort_code_text} .= '  $self->{results}->[$a]->[' . "$this_sort_column" .'] ' . "$symbol" . ' $self->{results}->[$b]->[' . "$this_sort_column" . "] ||\n";
    } elsif ($this_sort_method =~ /^.d$/i) {
      $self->{sort_code_text} .= '  $self->{results}->[$b]->[' . "$this_sort_column" .'] ' . "$symbol" . ' $self->{results}->[$a]->[' . "$this_sort_column" . "] ||\n";
    }
  }
  # sadly, this line is to unbug vi {
  $self->{sort_code_text} =~ s/\s*\|\|\s*$/\n\}/;
}

sub make_sort_code_ref {
  my $self = shift;
  return if($self->{sort_code_ref} && ref $self->{sort_code_ref} eq 'CODE');
  $self->make_sort_code_text;
  $self->{sort_code_ref} = eval $self->{sort_code_text};
  if($@) {
    die "$self->{sort_code_text}\ndid not lead to a valid CODE ref";
  }
}

1;

__END__