File Coverage

blib/lib/IntRange/Iter.pm

Criterion	Covered	Total	%
statement	39	40	97.5
branch	20	22	90.9
condition	9	10	90.0
subroutine	5	5	100.0
pod	1	1	100.0
total	74	78	94.8

package IntRange::Iter;

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2021-08-01'; # DATE
our $DIST = 'IntRange-Iter'; # DIST
our $VERSION = '0.006'; # VERSION

use strict;
use warnings;

use Exporter qw(import);
our @EXPORT_OK = qw(intrange_iter);

# allow_dash
our $re1a = qr/\A(?:
                   (?:(?:-?[0-9]+)(?:\s*-\s*(?:-?[0-9]+))?)
                   (
                       \s*,\s*
                       (?:(?:-?[0-9]+)(?:\s*-\s*(?:-?[0-9]+))?)
                   )*
               )\z/x;
our $re1b = qr/\A
               (?:\s*,\s*)?(?:
                   (-?[0-9]+)\s*-\s*(-?[0-9]+) | (-?[0-9]+)
               )
              /x;

# allow_dotdot
our $re2a = qr/\A(?:
                   (?:(?:-?[0-9]+)(?:\s*\.\.\s*(?:-?[0-9]+))?)
                   (
                       \s*,\s*
                       (?:(?:-?[0-9]+)(?:\s*\.\.\s*(?:-?[0-9]+))?)
                   )*
               )\z/x;
our $re2b = qr/\A
               (?:\s*,\s*)?(?:
                   (-?[0-9]+)\s*\.\.\s*(-?[0-9]+) | (-?[0-9]+)
               )
              /x;

# allow_dash + allow dotdot
our $re3a = qr/\A(?:
                   (?:(?:-?[0-9]+)(?:\s*(?:-|\.\.)\s*(?:-?[0-9]+))?)
                   (
                       \s*,\s*
                       (?:(?:-?[0-9]+)(?:\s*(?:-|\.\.)\s*(?:-?[0-9]+))?)
                   )*
               )\z/x;
our $re3b = qr/\A
               (?:\s*,\s*)?(?:
                   (-?[0-9]+)\s*(?:-|\.\.)\s*(-?[0-9]+) | (-?[0-9]+)
               )
              /x;

sub intrange_iter {
    my $opts = ref($_[0]) eq 'HASH' ? shift : {};
    my $intrange = shift;

    my $allow_dash   = $opts->{allow_dash} // 1;
    my $allow_dotdot = $opts->{allow_dotdot} // 0;
    unless ($allow_dash || $allow_dotdot) { die "At least must enable allow_dash or allow_dotdot" }

    my ($re_a, $re_b);
    if ($allow_dash && $allow_dotdot) { ($re_a, $re_b) = ($re3a, $re3b) }
    elsif ($allow_dash)               { ($re_a, $re_b) = ($re1a, $re1b) }
    elsif ($allow_dotdot)             { ($re_a, $re_b) = ($re2a, $re2b) }

    unless ($intrange =~ $re_a) {
        die "Invalid syntax for intrange, please use a (1), a-b (1-3), or sequence of a-b (1,5-10,15)";
    }

    my @subranges;
    while ($intrange =~ s/$re_b//) {
        push @subranges, defined($1) ? [$1, $2] : $3;
    }
    #use DD; dd \@subranges;
    my $cur_subrange = 0;
    my ($m, $n);
    return sub {
      RESTART:
        return undef if $cur_subrange > $#subranges;
        if (ref $subranges[$cur_subrange] eq 'ARRAY') {
            unless (defined $m) {
                ($m, $n) = (@{ $subranges[$cur_subrange] });
            }
            if ($m > $n) {
                $cur_subrange++;
                undef $m; undef $n;
                goto RESTART;
            } else {
                return $m++;
            }
        } else {
            return $subranges[$cur_subrange++];
        }
    };
}

1;
# ABSTRACT: Generate a coderef iterator from an int range specification (e.g. '1,5-10,20')

__END__