File Coverage

blib/lib/Sort/Sub.pm

Criterion	Covered	Total	%
statement	49	49	100.0
branch	10	12	83.3
condition	4	4	100.0
subroutine	7	7	100.0
pod	1	1	100.0
total	71	73	97.2

package Sort::Sub;

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2020-05-25'; # DATE
our $DIST = 'Sort-Sub'; # DIST
our $VERSION = '0.120'; # VERSION

use 5.010001;
use strict 'subs', 'vars';
use warnings;
use Log::ger;

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 => {
        'x.name.is_plural' => 1,
        'x.name.singular' => 'sort_arg',
        summary => 'Arguments to pass to the Sort::Sub::* routine',
        schema => ['array*', of=>'str*'],
        element_completion => sub {
            my %cargs = @_;

            # do we have the routine already? if yes, extract the metadata
            my $rname = $cargs{args}{sort_sub};
            return [] unless defined $rname;

            my $mod = "Sort::Sub::$rname";
            (my $mod_pm = "$mod.pm") =~ s!::!/!g;
            eval { require $mod_pm };
            return {message=>"Cannot load $mod: $@"} if $@;
            my $meta;
            eval { $meta = $mod->meta };
            return [] unless $meta;

            require Complete::Sequence;
            return Complete::Sequence::complete_sequence(
                word => $cargs{word},
                sequence => [
                    sub {
                        [$meta->{args} ? keys(%{ $meta->{args} }) : ()];
                    },
                    '=',
                    sub {
                        my $stash = shift;
                        my $argname = $stash->{completed_item_words}[0];
                        return [] unless defined $argname;

                        my $argspec = $meta->{args}{$argname};
                        return [] unless $argspec->{schema};

                        require Complete::Sah;
                        require Complete::Util;
                        Complete::Util::arrayify_answer(
                            Complete::Sah::complete_from_schema(
                                word => $stash->{cur_word},
                                schema => $argspec->{schema},
                            )
                          );

                    },
                ],
            );
        },
    },
);

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 [ <OPTS> ]';
    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__

=pod

=encoding UTF-8

=head1 NAME

Sort::Sub - Collection of sort subroutines

=head1 VERSION

This document describes version 0.120 of Sort::Sub (from Perl distribution Sort-Sub), released on 2020-05-25.

=head1 SYNOPSIS

 use Sort::Sub qw($naturally);

 my @sorted = sort $naturally ('track1.mp3', 'track10.mp3', 'track2.mp3', 'track1b.mp3', 'track1a.mp3');
 # => ('track1.mp3', 'track1a.mp3', 'track1b.mp3', 'track2.mp3', 'track10.mp3')

Request as subroutine:

 use Sort::Sub qw(naturally);

 my @sorted = sort {naturally} (...);

Request a reverse sort:

 use Sort::Sub qw($naturally<r>);

 my @sorted = sort $naturally (...);
 # => ('track10.mp3', 'track2.mp3', 'track1b.mp3', 'track1a.mp3', 'track1.mp3')

Request a case-insensitive sort:

 use Sort::Sub qw($naturally<i>);

 my @sorted = sort $naturally (...);

Request a case-insensitive, reverse sort:

 use Sort::Sub qw($naturally<ir>);

 my @sorted = sort $naturally ('track2.mp3', 'Track1.mp3', 'Track10.mp3');
 => ('Track10.mp3', 'track2.mp3', 'Track1.mp3')

Pass arguments to sort generator routine:

 use Sort::Sub '$by_num_of_colons', {pattern=>':'};

 my @sorted = sort $by_num_of_colons ('a::','b:','c::::','d:::');
 => ('b:','a::','d:::','c::::')

Request a coderef directly, without using the import interface:

 use Sort::Sub;

 my $naturally = Sort::Sub::get_sorter('naturally');
 my $naturally = Sort::Sub::get_sorter('$naturally');
 my $rev_naturally = Sort::Sub::get_sorter('naturally<r>');

=head1 DESCRIPTION

L<Sort::Sub> and C<Sort::Sub::*> are a convenient packaging of any kind of
subroutine which you can use for C<sort()>.

To use Sort::Sub, you import a list of:

 ["$"]NAME [ "<" [i][r] ">" ]

Where NAME is actually searched under C<Sort::Sub::*> namespace. For example:

 naturally

will attempt to load C<Sort::Sub::naturally> module and call its C<gen_sorter>
subroutine.

You can either request a subroutine name like the above or a variable name (e.g.
C<$naturally>).

After the name, you can add some options, enclosed with angle brackets C<< <>
>>. There are some known options, e.g. C<i> (for case-insensitive sort) or C<r>
(for reverse sort). Some examples:

 naturally<i>
 naturally<r>
 naturally<ri>

=head1 GUIDELINES FOR WRITING A SORT::SUB::* MODULE

The name should be in lowercase. It should be an adverb (e.g. C<naturally>) or a
phrase with words separated by underscore (C<_>) and the phrase begins with
C<by> (e.g. C<by_num_and_non_num_parts>).

The module must contain a C<gen_sorter> subroutine. It will be called with:

 ($is_reverse, $is_ci, $args)

Where C<$is_reserve> will be set to true if user requests a reverse sort,
C<$is_ci> will be set to true if user requests a case-insensitive sort. C<$args>
is hashref to pass additional arguments to the C<gen_sorter()> routine. The
subroutine should return a code reference.

The module should also contain a C<meta> subroutine which returns a metadata
L<DefHash>. Known properties (keys) include: C<v> (currently at 1), C<summary>,
C<compares_record> (bool, if set to true then sorter will be fed records C<<
[$data, $order] >> instead of just C<$data>; C<$order> is a number that can be
line number of array index; this allows sorter to sort by additional information
instead of just the data items). Other metadata properties will be added in the
future.

=head1 FUNCTIONS

=head2 get_sorter

Usage:

 my $coderef = Sort::Sub::get_sorter('SPEC' [ , \%args [ , $with_meta ] ]);

Example:

 my $rev_naturally = Sort::Sub::get_sorter('naturally<r>');

This is an alternative to using the import interface. This function is not
imported.

If C<$with_meta> is set to true, will return this:

 ($sorter, $meta)

instead of just the C<$sorter> subroutine.

=head1 HOMEPAGE

Please visit the project's homepage at L<https://metacpan.org/release/Sort-Sub>.

=head1 SOURCE

Source repository is at L<https://github.com/perlancar/perl-Sort-Sub>.

=head1 BUGS

Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Sort-Sub>

When submitting a bug or request, please include a test-file or a
patch to an existing test-file that illustrates the bug or desired
feature.

=head1 SEE ALSO

Other additional C<Sort::Sub::*> not bundled in this distribution.

Supporting CLI's: L<sortsub> (from L<App::sortsub>), L<sorted> (from
L<App::sorted>), CLI's from L<App::SortSubUtils>.

=head1 AUTHOR

perlancar <[e-mail]>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2020, 2019, 2018, 2016, 2015 by [e-mail].

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut