File Coverage

blib/lib/Sort/Sub/by_count.pm
Criterion Covered Total %
statement 34 36 94.4
branch 8 18 44.4
condition 1 3 33.3
subroutine 7 8 87.5
pod 0 2 0.0
total 50 67 74.6


line stmt bran cond sub pod time code
1             package Sort::Sub::by_count;
2              
3             our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
4             our $DATE = '2020-02-28'; # DATE
5             our $DIST = 'Sort-Sub'; # DIST
6             our $VERSION = '0.117'; # VERSION
7              
8 1     1   16 use 5.010001;
  1         3  
9 1     1   4 use strict;
  1         1  
  1         16  
10 1     1   4 use warnings;
  1         2  
  1         195  
11              
12             sub meta {
13             return {
14 0     0 0 0 v => 1,
15             summary => 'Sort by number of occurrences of pattern in string',
16             };
17             }
18              
19             sub _pattern_to_re {
20 1     1   1 my $args = shift;
21              
22 1         1 my $re;
23 1 50       2 my $pattern = $args->{pattern}; defined $pattern or die "Please specify pattern";
  1         1  
24 1 50       3 if ($args->{fixed_string}) {
25 0 0       0 $re = $args->{ignore_case} ? qr/\Q$pattern/i : qr/\Q$pattern/;
26             } else {
27 1 50       1 eval { $re = $args->{ignore_case} ? qr/$pattern/i : qr/$pattern/ };
  1         11  
28 1 50       3 die "Invalid pattern: $@" if $@;
29             }
30              
31 1         2 $re;
32             }
33              
34             sub gen_sorter {
35 1     1 0 3 my ($is_reverse, $is_ci, $args) = @_;
36              
37 1 50       3 die __PACKAGE__.": Please specify 'pattern'" unless defined $args->{pattern};
38              
39 1         3 my $re = _pattern_to_re($args);
40              
41             sub {
42 1     1   6 no strict 'refs';
  1         2  
  1         154  
43              
44 4     4   6 my $caller = caller();
45 4 50       5 my $a = @_ ? $_[0] : ${"$caller\::a"};
  4         8  
46 4 50       5 my $b = @_ ? $_[1] : ${"$caller\::b"};
  4         6  
47              
48 4         5 my $count_a = 0; $count_a++ while $a =~ /$re/g;
  4         44  
49 4         7 my $count_b = 0; $count_b++ while $b =~ /$re/g;
  4         15  
50              
51 4 50 33     19 ($is_reverse ? -1 : 1)*(
52             ($count_a <=> $count_b) ||
53             ($is_ci ? lc($a) cmp lc($b) : $a cmp $b)
54             );
55 1         5 };
56             }
57              
58             1;
59             # ABSTRACT: Sort by number of occurrences of pattern in string
60              
61             __END__
62              
63             =pod
64              
65             =encoding UTF-8
66              
67             =head1 NAME
68              
69             Sort::Sub::by_count - Sort by number of occurrences of pattern in string
70              
71             =head1 VERSION
72              
73             This document describes version 0.117 of Sort::Sub::by_count (from Perl distribution Sort-Sub), released on 2020-02-28.
74              
75             =for Pod::Coverage ^(gen_sorter|meta)$
76              
77             =head1 SYNOPSIS
78              
79             Generate sorter (accessed as variable) via L<Sort::Sub> import:
80              
81             use Sort::Sub '$by_count'; # use '$by_count<i>' for case-insensitive sorting, '$by_count<r>' for reverse sorting
82             my @sorted = sort $by_count ('item', ...);
83              
84             Generate sorter (accessed as subroutine):
85              
86             use Sort::Sub 'by_count<ir>';
87             my @sorted = sort {by_count} ('item', ...);
88              
89             Generate directly without Sort::Sub:
90              
91             use Sort::Sub::by_count;
92             my $sorter = Sort::Sub::by_count::gen_sorter(
93             ci => 1, # default 0, set 1 to sort case-insensitively
94             reverse => 1, # default 0, set 1 to sort in reverse order
95             );
96             my @sorted = sort $sorter ('item', ...);
97              
98             Use in shell/CLI with L<sortsub> (from L<App::sortsub>):
99              
100             % some-cmd | sortsub by_count
101             % some-cmd | sortsub by_count --ignore-case -r
102              
103             =head1 DESCRIPTION
104              
105             This module can generate sort subroutine. It is meant to be used via L<Sort::Sub>, although you can also use it directly via C<gen_sorter()>.
106              
107             =head1 ARGUMENTS
108              
109             =head2 pattern
110              
111             Regex pattern or string.
112              
113             =head2 fixed_string
114              
115             Bool. If true will assume L</pattern> is a fixed string instead of regular
116             expression.
117              
118             =head2 ignore_case
119              
120             Bool.
121              
122             =head1 HOMEPAGE
123              
124             Please visit the project's homepage at L<https://metacpan.org/release/Sort-Sub>.
125              
126             =head1 SOURCE
127              
128             Source repository is at L<https://github.com/perlancar/perl-Sort-Sub>.
129              
130             =head1 BUGS
131              
132             Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Sort-Sub>
133              
134             When submitting a bug or request, please include a test-file or a
135             patch to an existing test-file that illustrates the bug or desired
136             feature.
137              
138             =head1 SEE ALSO
139              
140             L<Sort::Sub>
141              
142             L<Sort::Naturally>
143              
144             =head1 AUTHOR
145              
146             perlancar <perlancar@cpan.org>
147              
148             =head1 COPYRIGHT AND LICENSE
149              
150             This software is copyright (c) 2020, 2019, 2018, 2016, 2015 by perlancar@cpan.org.
151              
152             This is free software; you can redistribute it and/or modify it under
153             the same terms as the Perl 5 programming language system itself.
154              
155             =cut