use strict;
use warnings;
+use Exporter 'import';
+
our $VERSION = '1.00';
+our @EXPORT_OK = qw(rangematch);
sub new {
my ($class, $values) = @_;
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__
--- /dev/null
+#!/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 $@;
+}
+