view release on metacpan or  search on metacpan

lib/Sort/Fields.pm  view on Meta::CPAN

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.003';

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$@";