File Coverage

blib/lib/Sort/Sub.pm

Criterion	Covered	Total	%
statement	46	46	100.0
branch	10	12	83.3
condition	4	4	100.0
subroutine	6	6	100.0
pod	1	1	100.0
total	67	69	97.1

package Sort::Sub;

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2020-02-28'; # DATE
our $DIST = 'Sort-Sub'; # DIST
our $VERSION = '0.118'; # VERSION

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

our $re_spec = qr/\A(\$)?(\w+)(?:<(\w*)>)?\z/;

our %argsopt_sortsub = (
    sort_sub => {
        summary => 'Name of a Sort::Sub::* module (without the prefix)',
        schema => ['sortsub::spec*'],
    },
    sort_args => {
        summary => 'Arguments to pass to the Sort::Sub::* routine',
        schema => ['hash*', of=>'str*'],
    },
);

sub get_sorter {
    my ($spec, $args, $with_meta) = @_;

    my ($is_var, $name, $opts) = $spec =~ $re_spec
        or die "Invalid sorter spec '$spec', please use: ".
        '[$]NAME [  ]';
    require "Sort/Sub/$name.pm";
    $opts //= "";
    my $is_reverse = $opts =~ /r/;
    my $is_ci      = $opts =~ /i/;
    my $gen_sorter = \&{"Sort::Sub::$name\::gen_sorter"};
    my $sorter = $gen_sorter->($is_reverse, $is_ci, $args // {});
    if ($with_meta) {
        my $meta = {};
        eval { $meta = &{"Sort::Sub::$name\::meta"}() };
        warn if $@;
        return ($sorter, $meta);
    } else {
        return $sorter;
    }
}

sub import {
    my $class = shift;
    my $caller = caller;

    my $i = -1;
    while (1) {
        $i++;
        last if $i >= @_;
        my $import = $_[$i];
        my $args = {};
        if (ref $_[$i+1] eq 'HASH') {
            $args = $_[$i+1];
            $i++;
        }
        my $sorter = get_sorter($import, $args);
        my ($is_var, $name) = $import =~ $re_spec; # XXX double matching
        if ($is_var) {
            ${"$caller\::$name"} = \&$sorter;
        } else {
            no warnings 'redefine';
            *{"$caller\::$name"} = \&$sorter;
        }
    }
}

1;
# ABSTRACT: Collection of sort subroutines

__END__