File Coverage

blib/lib/Sort/Fields.pm

Criterion	Covered	Total	%
statement	91	93	97.8
branch	45	48	93.7
condition	7	9	77.7
subroutine	8	8	100.0
pod	0	4	0.0
total	151	162	93.2

package Sort::Fields;

use strict;
use vars qw($VERSION @EXPORT);

use Exporter qw(import);
require 5.003_03;
;
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
@EXPORT = qw(
	make_fieldsort
	fieldsort
	make_stable_fieldsort
	stable_fieldsort
);
$VERSION = '1.001';

use Carp;

sub make_fieldsort {
	my $selfname;
	if ((caller)[0] eq 'Sort::Fields') {
		($selfname) = (caller 1)[3] =~ /([^:]*)$/;
	} else {
		$selfname = 'make_fieldsort'
	};
	unless (@_) {
		croak "$selfname requires argument(s)";
	}

	my ($sep, $cols);
	if (ref $_[0]) {
		$sep = '\\s+'
	} else {
		$sep = shift;
	}
	unless (ref($cols = shift) eq 'ARRAY') {
		croak "$selfname field specifiers must be in anon array";
	}
	my (@sortcode, @col);
	my $level = 1;
	my $maxcol = -1;
	my $stable = 0;
	if (@$cols and $$cols[0] eq '-') {
		shift @$cols;
		$stable = 1;
	}
	unless (@$cols) {
		croak "$selfname must have at least one field specifier";
	}
	for (@$cols) {
		unless (/^-?\d+n?$/) {
			croak "improperly formatted $selfname column specifier '$_'";
		}
		my ($a, $b) = /^-/ ? qw(b a) : qw(a b);
		my $op = /n$/ ? '<=>' : 'cmp';
		my ($col) = /^-?(\d+)/;
		if ($col == 0) {  # column 0 gives the entire string
			push @sortcode, "\$${a}->[0] $op \$${b}->[0]";
			next;
		}
		push @col, (/(\d+)/)[0] - 1;
		$maxcol = $col[-1] if $maxcol < $col[-1];
		if ($stable) {
			# indices are offset by 1 in this case
			my $levp1 = $level + 1;
			push @sortcode, "\$${a}->[$levp1] $op \$${b}->[$levp1]";
		} else {
			push @sortcode, "\$${a}->[$level] $op \$${b}->[$level]";
		}
		$level++;
	}
	# have to check this all by itself, since if there's a regex
    # error it won't show up until the sub is called (urk!)
	eval '"" =~ /$sep/';
	if ($@) {
		croak "probable regexp error in $selfname arg: /$sep/\n$@";
	}
	my $splitfunc;
	$splitfunc = eval 'sub { (split /$sep/o, $_, $maxcol + 2)[@col] } ';
	if ($@) {
		die "eval failed in $selfname (internal error?)\n$@";
	}
	my $sortcode = join " or ", @sortcode;
	my $sub;
	if ($stable) {
		my $i;  # the $i for the stable sort closure
		$sub = eval qq{
			sub {
				if (\$^W and not wantarray) {
					carp "fieldsort called in scalar or void context";
				}
				\$i = 0;  # reset counter in case reusing this closure
				map \$_->[0],
					sort { $sortcode or \$a->[1] <=> \$b->[1] }
					map [\$_, \$i++, \$splitfunc->(\$_)],
					\@_;
			}
		}
	} else {
		$sub = eval qq{
			sub {
				if (\$^W and not wantarray) {
					carp "fieldsort called in scalar or void context";
				}
				map \$_->[0],
					sort { $sortcode }
					map [\$_, \$splitfunc->(\$_)],
					\@_;
			}
		}
	}
	if ($@) {
		die "eval failed in $selfname (internal error?)\n$@";
	}
	$sub;
}

sub make_stable_fieldsort {
	unless (@_) {
		croak "make_stable_fieldsort requires argument(s)";
	}
	if (ref $_[0] eq 'ARRAY') {
		unshift @{$_[0]}, '-';
	} elsif (@_ > 1 and ref $_[1] eq 'ARRAY') {
		unshift @{$_[1]}, '-';
	}
	make_fieldsort @_;
}

sub fieldsort {
	unless (@_) {
		croak "fieldsort requires argument(s)";
	}
	my ($sep, $cols);
	if (ref $_[0]) {
		$sep = '\\s+'
	} else {
		$sep = shift;
	}
	$cols = shift;
	make_fieldsort($sep, $cols)->(@_);
}

sub stable_fieldsort {
	unless (@_) {
		croak "stable_fieldsort requires argument(s)";
	}
	my ($sep, $cols);
	if (ref $_[0] eq 'ARRAY') {
		$sep = '\\s+';
		unshift @{$_[0]}, '-';
	} elsif (@_ > 1 and ref $_[1] eq 'ARRAY') {
		$sep = shift;
		unshift @{$_[1]}, '-';
	}
	$cols = shift;
	make_fieldsort($sep, $cols)->(@_);
}


1;
__END__