X-Git-Url: http://git.shiar.net/gitweb.cgi/perl/list-index.git/blobdiff_plain/a621cd10e5c167968a778cb6a1a4f319d4949a7a..d61e8685992586de85f6b7b58fee20f15c8111b0:/lib/List/Index.pm

diff --git a/lib/List/Index.pm b/lib/List/Index.pm
index 513ce4f..6a818bb 100644
--- a/lib/List/Index.pm
+++ b/lib/List/Index.pm
@@ -4,11 +4,14 @@ use 5.010;
 use strict;
 use warnings;
 
+use Exporter 'import';
+
 our $VERSION = '1.00';
+our @EXPORT_OK = qw(rangematch);
 
 sub new {
 	my ($class, $values) = @_;
-	bless [map { tr/{/./; $_ } sort map { s/[^a-z]/{/g; $_ } @$values], $class;
+	bless [sort map { s/[^a-z]/./g; $_ } @$values], $class;
 }
 
 sub ranges {
@@ -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__