X-Git-Url: http://git.shiar.net/perl/list-index.git/blobdiff_plain/0433a4eb785409f46a2d61e668fda84bd87c3148..356b069f60818a6ef5f0f8cf97a78924675c2c5b:/lib/List/Index.pm diff --git a/lib/List/Index.pm b/lib/List/Index.pm index 7214ced..bf4e04d 100644 --- a/lib/List/Index.pm +++ b/lib/List/Index.pm @@ -23,18 +23,38 @@ sub ranges { my $pages = $options->{pages } || 1 + int $#$self / $pagesize; $pagesize = @$self / $pages; - my $offset = 0; - my @links; + my $offset = $pagesize; + my @links = (['']); while ($offset < @$self) { my $link = substr $self->[$offset], 0, $length; if ($context) { - my $trim = 1; - my $before = $offset > $context ? $self->[$offset - $context] : ''; - for my $match (split //, $before) { - scalar $link =~ /\G\Q$match/g or last; - $trim++; + { + # take a value slightly before the current offset + my $before = $offset > $context ? $self->[$offset - $context] : '.'; + # see how much of it matches the current link + my $trim = 1; + for my $match (split //, $before) { + scalar $link =~ /\G\Q$match/g or last; + $trim++; + } + # truncate link upto where the earlier value starts to differ + substr($link, $trim) = '' unless $trim > length $link; + } + + if ($offset + $context < $#$self) { + # take a value after the current offset + my $after = $self->[$offset + $context]; + # see how much of it matches the current link + my $trim = 1; + for my $match (split //, $after) { + scalar $link =~ /\G\Q$match/g or last; + $trim++; + } + # use this link if it's shorter + if ($trim < length $link) { + $link = substr $after, 0, $trim; + } } - substr($link, $trim) = '' unless $trim > length $link; } push @links, [$link]; @@ -43,8 +63,8 @@ sub ranges { for my $i (0 .. $#links - 1) { my ($link, $lastchar) = $links[$i + 1]->[0] =~ /(.*)(.)/; - $link .= $lastchar eq '.' ? 'z' : chr( ord($lastchar) - 1 ) - unless $lastchar eq 'a'; + $link .= $lastchar le 'a' ? '.' : chr( ord($lastchar) - 1 ); + next if $link eq $links[$i]->[0] and $i; $links[$i]->[1] = $link; } $links[-1]->[1] = ''; @@ -59,6 +79,10 @@ sub rangematch { my @allow; if (length $s1) { + if (length $s2) { + $s1 le $s2 or $s1 =~ /^\Q$s2/ or return undef; + } + my $prefix = ''; my $char; for my $i (0 .. length($s1) - 1) {