File Coverage

blib/lib/Sort/BySpec.pm

Criterion	Covered	Total	%
statement	68	77	88.3
branch	33	40	82.5
condition	12	15	80.0
subroutine	9	9	100.0
pod	2	2	100.0
total	124	143	86.7

package Sort::BySpec;

our $DATE = '2021-05-01'; # DATE
our $VERSION = '0.040'; # VERSION

use 5.010001;
use strict 'subs', 'vars';
use warnings;

use Exporter qw(import);
our @EXPORT_OK = qw(sort_by_spec cmp_by_spec);

our %SPEC;

$SPEC{':package'} = {
    v => 1.1,
    summary => 'Sort array (or create a list sorter) according to '.
        'specification',
};

$SPEC{sort_by_spec} = {
    v => 1.1,
    summary => 'Sort array (or create a list sorter) according to '.
        'specification',
    description => <<'_',


_
    args => {
        spec => {
            schema => 'array*',
            req => 1,
            pos => 0,
        },
        xform => {
            schema => 'code*',
            summary => 'Code to return sort keys from data elements',
            description => <<'_',

This is just like `xform` in `Sort::ByExample`.

_
        },
        reverse => {
            summary => 'If set to true, will reverse the sort order',
            schema => ['bool*', is=>1],
        },
        array => {
            schema => 'array*',
        },
    },
    result => {
        summary => 'Sorted array, or sort coderef',
        schema => ['any*', of=>['array*','code*']],
        description => <<'_',

If array is specified, will returned the sorted array. If array is not specified
in the argument, will return a sort subroutine that can be used to sort a list
and return the sorted list.

_
    },
    result_naked => 1,
    examples => [
        {
            summary => 'Sort according to a sequence of scalars (like Sort::ByExample)',
            args => {
                spec => ['foo', 'bar', 'baz'],
                array => [1, 2, 3, 'bar', 'a', 'b', 'c', 'baz'],
            },
        },
        {
            summary => 'Like previous example, but reversed',
            args => {
                spec => ['foo', 'bar', 'baz'],
                array => [1, 2, 3, 'bar', 'a', 'b', 'c', 'baz'],
                reverse => 1,
            },
        },
        {
            summary => 'Put integers first (in descending order), then '.
                'a sequence of scalars, then others (in ascending order)',
            args => {
                spec => [
                    qr/\A\d+\z/ => sub { $_[1] <=> $_[0] },
                    'foo', 'bar', 'baz',
                    qr// => sub { $_[0] cmp $_[1] },
                ],
                array => ["qux", "b", "a", "bar", "foo", 1, 10, 2],
            },
        },
    ],
};
sub sort_by_spec {
    my %args = @_;

    my $spec  = $args{spec};
    my $xform = $args{xform};

    my $code_get_rank = sub {
        my $val = shift;

        my $j;
        for my $which (0..2) { # 0=scalar, 1=regexp, 2=code
            $j = -1;
            while ($j < $#{$spec}) {
                $j++;
                my $spec_elem = $spec->[$j];
                my $ref = ref($spec_elem);
                if (!$ref) {
                    if ($which == 0 && $val eq $spec_elem) {
                        return($j);
                    }
                } elsif ($ref eq 'Regexp') {
                    my $sortsub;
                    if ($j < $#{$spec} && ref($spec->[$j+1]) eq 'CODE') {
                        $sortsub = $spec->[$j+1];
                    }
                    if ($which == 1 && $val =~ $spec_elem) {
                        return($j, $sortsub);
                    }
                    $j++ if $sortsub;
                } elsif ($ref eq 'CODE') {
                    my $sortsub;
                    if ($j < $#{$spec} && ref($spec->[$j+1]) eq 'CODE') {
                        $sortsub = $spec->[$j+1];
                    }
                    if ($which == 2 && $spec_elem->($val)) {
                        return($j, $sortsub);
                    }
                    $j++ if $sortsub;
                } else {
                    die "Invalid spec[$j]: not a scalar/Regexp/code";
                }
            } # loop element of spec
        } # which
        return($j+1);
    };

    if ($args{_return_cmp}) {
        my $cmp = sub {
            my ($a, $b);

            if (@_ >= 2) {
                $a = $_[0];
                $b = $_[1];
            } else {
                my $caller = caller();
                $a = ${"caller\::a"};
                $b = ${"caller\::b"};
            }

            if ($xform) {
                $a = $xform->($a);
                $b = $xform->($b);
            }

            if ($args{reverse}) {
                ($a, $b) = ($b, $a);
            }

            my ($rank_a, $sortsub) = $code_get_rank->($a);
            my ($rank_b          ) = $code_get_rank->($b);

            if ($rank_a != $rank_b) {
                return $rank_a <=> $rank_b;
            }
            return 0 unless $sortsub;
            return $sortsub->($a, $b);
        };
        return $cmp;
    } else {
        # use schwartzian transform to speed sorting longer lists
        my $sorter = sub {
            return map { $_->[0] }
                sort {
                    $a->[2] <=> $b->[2] ||
                        ($a->[3] ? $a->[3]($a->[1], $b->[1]) : 0) }
                    map {
                        my $x = $xform ? $xform->($_) : $_;
                        [$_, $x, $code_get_rank->($x)]
                    } @_;
        };

        if ($args{array}) {
            return [$sorter->(@{ $args{array} })];
        }
        return $sorter;
    }
}

$SPEC{cmp_by_spec} = do {
    # poor man's "clone"
    my $meta = { %{ $SPEC{sort_by_spec} } };
    $meta->{summary} = 'Create a compare subroutine to be used in sort()';
    $meta->{args} = { %{$meta->{args}} };
    delete $meta->{args}{array};
    $meta->{result} = {
        schema => ['code*'],
    };
    delete $meta->{examples};
    $meta;
};
sub cmp_by_spec {
    sort_by_spec(
        @_,
        _return_cmp => 1,
    );
}

1;
# ABSTRACT: Sort array (or create a list sorter) according to specification

__END__