XXX: rangematch()

diff --git a/lib/List/Index.pm b/lib/List/Index.pm
index c7992211b4a3609e3cb1f97567a5ae63f4fc9191..6a818bb23ec78e766a0c808c52681a38260142ec 100644 (file)
--- a/lib/List/Index.pm
+++ b/lib/List/Index.pm
@@ -4,7 +4,10 @@ use 5.010;
 use strict;
 use warnings;
 
+use Exporter 'import';
+
 our $VERSION = '1.00';
+our @EXPORT_OK = qw(rangematch);
 
 sub new {
        my ($class, $values) = @_;
@@ -49,6 +52,46 @@ sub ranges {
        return \@links;
 }
 
+sub rangematch {
+       my ($link) = @_;
+       my ($s1, $s2) = $link =~ /([^-]*) - ([^-]*)/x
+               or return qr/^\Q$link/i;
+       my @allow;
+
+       if (length $s1) {
+               my $prefix = '';
+               my $c1;
+               for my $i (0 .. length($s1) - 1) {
+                       $c1 = substr $s1, $i, 1;
+                       my $c2 = length $s2 <= $i ? undef : substr $s2, $i, 1;
+                       my $next = $i + 1 >= length($s1) ? $c1 : chr( ord($c1) + 1 );
+                       $next le $c2 or next if defined $c2;
+                       my $last = defined $c2 && $i == 0 ? chr( ord($c2) - (length $s2 > 1) ) : 'z';
+                       push @allow, $prefix."[$next-$last]";
+               }
+               continue {
+                       $prefix .= $c1;
+               }
+       }
+
+       if (length $s2) {
+               my $prefix = '';
+               for my $i (0 .. length($s2) - 1) {
+                       my $c1 = length $s1 <= $i ? undef : substr $s1, $i, 1;
+                       my $c2 = substr $s2, $i, 1;
+                       my $last = 'z';
+                       push @allow, "$prefix(?![$c2-$last])"
+                               if $i or $s1 eq '';
+                       $prefix .= $c2;
+               }
+               push @allow, $prefix
+                       unless length $s1 > length $s2 or length $s1 != 0 && length $s2 == 1; #TODO
+       }
+
+       my $match = sprintf @allow <= 1 ? '%s' : '(?:%s)', join('|', @allow);
+       return qr/^$match/i;
+}
+
 1;
 
 __END__

diff --git a/t/20-links.t b/t/20-links.t
new file mode 100644 (file)
index 0000000..89f5dee
--- /dev/null
+++ b/t/20-links.t
@@ -0,0 +1,27 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+
+use Test::More tests => 13;
+use Test::NoWarnings;
+
+BEGIN { use_ok('List::Index' => 'rangematch'); }
+
+for (
+       [   q      => 'q'],
+       ['#foo.!$' => '\#foo\.\!\$'],
+       [    -q    =>            '(?:(?![q-z])|q)'],
+       [    -qqq  =>            '(?:(?![q-z])|q(?![q-z])|qq(?![q-z])|qqq)'],
+       [  'q-'    =>    '[q-z]'],
+       ['qqq-'    => '(?:[r-z]|q[r-z]|qq[q-z])'],
+       [  'q-x'   =>    '[q-x]'],
+       ['qqq-xxx' => '(?:[r-w]|q[r-z]|qq[q-z]|x(?![x-z])|xx(?![x-z])|xxx)'],
+       ['qqq-x'   => '(?:[r-x]|q[r-z]|qq[q-z])'],
+       ['qqq-q'   =>       '(?:q[r-z]|qq[q-z])'],
+       [  'q-xxx' =>                '(?:[q-w]|x(?![x-z])|xx(?![x-z])|xxx)'],
+) {
+       my ($in, $out) = @$_;
+       is(eval { rangematch($in) }, "(?i-xsm:^$out)", $in);
+       diag($@) if $@;
+}
+